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ABSTRACT 

Programming languages have been and will continue to be an 
important instrument for the automation of a wide variety of 
functions within industry and the Federal Government. Other 
instruments, such as program generators, application packages, 
query languages, and the like, are also available and their use 
is preferable in some circumstances. 

Given that conventional programming is the appropriate 
technique for a particular application, the choice among the 
various languages becomes an important issue. There are a great 
number of selection criteria, not all of which depend directly on 
the language itself. Broadly speaking, the criteria are based on 
1) the language and its implementation, 2) the application to be 
programmed, and 3) the user's existing facilities and software. 

This study presents a survey of selection factors for the 
major general-purpose languages: Ada*, BASIC, C, COBOL, FORTRAN, 
Pascal, and PL/I. The factors covered include not only the 
logical operations within each language, but also the advantages 
and disadvantages stemming from the current computing 
environment, e.g., software packages, microcomputers, and 
standards. The criteria associated with the application and the 
user's facilities are explained. Finally, there is a set of 
program examples to illustrate the features of the various 
languages. 

This volume includes the program examples. Volume 1 
contains the discussion of language selection criteria. 

Ke y w ords: Ada; alternatives to programming; BASIC; C; 
C0B0L7 FORTRAN; Pascal; PL/I; programming language 
features; programming languages; selection of programming 
language . 


* Ada is a registered trademark of the U. S. Government, 
Ada Joint Project Office. 
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1.0 INTRODUCTION 


In this volume, we shall illustrate the general style of 
each of the languages with'a program. These programs are only 
examples; they do not attempt to demonstrate the full capability 
of each language. On the other hand, the application chosen is 
complex enough that the programs do make significant use of 
several important language features, such as reading a file, 
interacting with a user, recursion, data abstraction, 
manipulation of arrays, pointers, and character strings, and some 
numeric calculation. Of particular note are the language 
features for modularizing a program of moderate size (about 1000 
lines). While no application can be completely language-neutral, 
this variety of requirements implies a relatively unbiased 
example. Finally, the application deals with a well-known realm 
(family relationships) in order to facilitate understanding of 
the programs. 

All of the programs solve the same problem, i.e., they 
accept the same input and produce output as nearly equivalent as 
possible. The input is a file of people, one person per record, 
and a series of user queries. In the file, each person's father 
and mother (if known), and spouse (if any) are identified. Given 
this information, the user may then specify any two persons in 
the file, and the program computes and displays the relationship 
(e.g., brother-in-law, second cousin) between those two. Also, 
based on the number and degree of common ancestors, the expected 
value for the proportion of common genetic material between the 
two is computed and displayed. 

The algorithms and data structures employed are roughly 
equivalent, but differ in detail owing to the language 
differences being illustrated. Generally, user-defined names are 
capitalized and language-defined keywords and identifiers are 
written in lower-case. In all the programs a directed graph is 
simulated, with the vertices representing people and the edges 
representing different types of direct relationships. The only 
direct relationships are parent, child, and spouse. Starting at 
one vertex, a search is conducted to find the shortest path to 
the other vertex. The types of edges encountered along the path, 
together with some additional information, determine the 
relationship. For instance, if the shortest path between XI and 
X4 is that XI is child of X2 , X2 is spouse of X3 , and X3 is 
parent of X4 , this would show that XI and X4 are step-siblings. 
It is assumed that the input file has already been validated and 
is correct. The user's requests, however, are checked. The 
algorithm to determine the shortest path is adapted from 
[Baas78]. The overall algorithm is expressed by the pseudo-code 
below. 

All of the programs, except the one in BASIC, have compiled 
and executed on at least one language processor which implements 
the corresponding standard or base document. The COBOL program, 
while conforming to both COBOL-74 and C0B0L-8x, is essentially a 
COBOL-74 program, since it does not exploit any of the new 
C0B0L-8x features. 
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Figure 1 - Algorithm for Program Examples 

for each record in input PEOPLE file do 
establish entry in PERSON array 
for all previous entries do 

compare this entry to previous, looking for 

immediate relationships: parent, child, or spouse 
if relationship found 

establish link (edge) between these two persons 
end if 
end for 
end for 
graph is now built 

while not request to stop 

prompt and read next request 
exit while-block if request to stop 
if syntax of request OK 

search for requested persons 
if exactly one of each person found 
if 1st person = 2nd person 

display "identical to self" 
else 

find shortest path between the two persons 
if no such path 

display "unrelated" 
el se 

analyze path for named relationships: 

path initially composed of parent, child, 

spouse edges 
resolve child-parent and child-spouse-parent 

to sibling 
resolve child-child-... and parent-parent-... 

to descendant (child*) or ancestor (parent*) 
resolve child*-sibling-parent* to cousin, 
child*-sibling to nephew, 
sibling-parent* to uncle 
display consolidated relationships 
compute proportion of common genetic material: 
traverse ancestors of personl, zeroing out 
traverse ancestors of personl, marking and 

accumulating genetic contribution 
traverse ancestors of person2, accumulating 

overlap with personl 
display results 
end if 
end if 
else 

display "duplicate name" or "not found" 
end if 
else 

display "invalid request" 
end if 
end while 
display "done" 
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Figure 2 - Input Data 


This figure shows some of the input data with which the 
program examples were tested. The format of each record is: 

Position Contents 


1-20 Name of person 

21-23 Unique 3-digit identifier of person 

24 Gender of person 

25-27 Identifier of father (000 if unknown) 

28-30 Identifier of mother (000 if unknown) 

31-33 Identifier of spouse (000 if none or unknown) 

Example of Input Data: 

John Smith 001M000000002 

Mary Smith 002F003000001 

Wilbur Finnegan 010M00000001 1 

Mary Finnegan 011F000000010 

James Smith 020M001002022 

Wilma Smith 022F01001 1020 

Marvin Hamlisch 031M000032000 

Melvin Hamlisch 033M000032000 

Martha Hamlisch 032F048043034 
Murgatroyd Whatsis 034M000000032 

Bentley Whatsis 035M034036000 

Myrna Whozat 036F000000000 

Bosworth Whatsis 037M034036000 

K48 048M000000043 

K43 043F041042048 

K41 041M000000042 

K42 042F000000041 

K46 046M045000000 

K45 045M048043000 

K47 047M044000000 

K44 044M041042000 

Velorus Davis 085M000000086 

Goldie Beacon 083F085086082 

Ross Beacon 082M000000083 

Velma Davis 086F000000085 

Floyd Davis 088M085084087 

Cindy Davis 084F000000000 

David Beacon 12 1M081 120000 

Norma Cousins 053F082083055 

Carmine Cousins 05 1M000000052 

Maria Cousins 052F000000051 

James Cousins 054M05 1052000 

C. John Cousins 055M051052053 

John Cousins 073M055053074 

Janet Cousins 074F 140141073 

Richard Cousins 07 7M073074000 

Paul Cousins 078M0730740O0 

Marie Cousins 07 9F073074000 


Page 4 


Figure 3 - Queries and Output 


This figure gives some examples of the results of running 
the programs. 


Enter two person-identifiers (name or number), 
separated by semicolon. Enter "stop" to stop. 
» 
Incorrect request format: null field preceding semicolon. 

Enter two person-identifiers (name or number), 

separated by semicolon. Enter "stop" to stop. 
x; x; x 

Incorrect request format: must be exactly one semicolon. 

Enter two person-identifiers (name or number), 
separated by semicolon. Enter "stop" to stop. 
x; x 
First person not found. 
Second person not found. 

Enter two person-identifiers (name or number), 
separated by semicolon. Enter "stop" to stop. 

Ill ; 111 
Christopher Delmonte is identical to himself. 

Enter two person-identifiers (name or number), 
separated by semicolon. Enter "stop" to stop. 
G6;John Smith 
G6 is not related to John Smith 

Enter two person-identifiers (name or number), 
separated by semicolon. Enter "stop" to stop. 
Carmine Cousinsjlll 
Duplicate names for first person - use numeric identifier. 

Enter two person-identifiers (name or number), 
separated by semicolon. Enter "stop" to stop. 
163; 145 
Shortest path between identified persons: 
Linda Lackluster is child of 
Millie Lackluster is child of 
Anna Pittypat is parent of 
Margaret Madison is spouse of 
Richard Madison is child of 
Victoria Pisces is parent of 
Maria Gotsocks is parent of 
Elzbieta Gotsocks 
Condensed path: 

Linda Lackluster is niece of 
Richard Madison is uncle of 
Elzbieta Gotsocks 
Proportion of common genetic material = O.OOOOOE+00 
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Figure 3 - Queries and Output (continued) 

Enter two person-identifiers (name or number), 

separated by semicolon. Enter "stop" to stop. 
094;145 
Shortest path between identified persons: 

Nancy Powers is child of 

Maxine Powers is child of 

Floyd Davis is child of 

Velorus Davis is parent of 

Goldie Beacon is parent of 

Norma Cousins is parent of 

John Cousins is spouse of 

Janet Cousins is child of 

Richard Madison is child of 

Victoria Pisces is parent of 

Maria Gotsocks is parent of 
Elzbieta Gotsocks 
Condensed path: 

Nancy Powers is 2nd half-cousin-in-law of 

Janet Cousins is cousin of 
Elzbieta Gotsocks 

Proportion of common genetic material = 0.00000E+00 

Enter two person-identifiers (name or number), 
separated by semicolon. Enter "stop" to stop. 
036;033 
Shortest path between identified persons : 
Myrna Whozat is parent of 

Bentley Whatsis is child of 
Murgatroyd Whatsis is spouse of 
Martha Hamlisch is parent of 
Melvin Hamlisch 
Condensed path: 

Myrna Whozat is mother of 

Bentley Whatsis is step-brother of 
Melvin Hamlisch 
Proportion of common genetic material = 0.00000E+00 

Enter two person-identifiers (name or number), 
separated by semicolon. Enter "stop" to stop. 
031;033 
Shortest path between identified persons : 
Marvin Hamlisch is child of 
Martha Hamlisch is parent of 
Melvin Hamlisch 
Condensed path: 

Marvin Hamlisch is half-brother of 
Melvin Hamlisch 
Proportion of common genetic material = 2.50000E-01 
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Figure 3 - Queries and Output (continued) 

Enter two person-identifiers (name or number), 

separated by semicolon. Enter "stop" to stop. 
145;090 
Shortest path between identified persons : 

Elzbieta Gotsocks is child of 

Maria Gotsocks is child of 

U. Pisces is parent of 

Richard Madison is parent of 

Janet Cousins is spouse of 

John Cousins is child of 

Norma Cousins is child of 

Goldie Beacon is child of 

Velorus Davis is parent of 

Floyd Davis is parent of 

Maxine Powers is spouse of 
Tim Powers 
Condensed path: 

Elzbieta Gotsocks is cousin-in-law of 

John Cousins is half-cousin-in-law once removed of 
Tim Powers 

Proportion of common genetic material = 0.00000E+00 

Enter two person-identifiers (name or number), 

separated by semicolon. Enter "stop" to stop. 
L6;R9 
Shortest path between identified persons: 

L6 is child of 

L5 is child of 

L4 is child of 

L3 is child of 

L2 is child of 

LI is child of 

LO is parent of 

Rl is parent of 

R2 is parent of 

R3 is parent of 

R4 is parent of 

R5 is parent of 

R6 is parent of 

R7 is parent of 

R8 is parent of 
R9 

Condensed path: 

L6 is 5th half-cousin 3 times removed of 
R9 

Proportion of common genetic material = 3.05176E-05 
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Figure 3 - Queries and Output (continued) 

Enter two person-identifiers (name or number), 

separated by semicolon. Enter "stop" to stop. 
W1;R14 
Shortest path between identified persons: 

Wl is spouse of 

LO is parent of 

Rl is parent of 

R2 is parent of 

R3 is parent of 

R4 is parent of 

R5 is parent of 

R6 is parent of 

R7 is parent of 

R8 is parent of 

R9 is parent of 

RIO is parent of 

Rll is parent of 

R12 is parent of 

R13 is parent of 
R14 

Condensed path: 

Wl is great*12-grand-step-f ather of 
R14 
Proportion of common genetic material = 0.O0O0OE+0O 

Enter two person-identifiers (name or number), 

separated by semicolon. Enter "stop" to stop. 
X8;L6 

Shortest path between identified persons: 

X8 is child of 

X7 is child of 

X6 is child of 

X5 is child of 

X4 is child of 

X3 is spouse of 

R4 is child of 

R3 is child of 

R2 is child of 

Rl is child of 

LO is parent of 

LI is parent of 

L2 is parent of 

L3 is parent of 

L4 is parent of 

L5 is parent of 
L6 

Condensed path: 

X8 is great*3-grand-step-son of 

R4 is 3rd half-cousin 2 times removed of 
L6 
Proportion of common genetic material = 0.00000E+00 
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Figure 3 - Queries and Output (continued) 

Enter two person-identifiers (name or number), 
separated by semicolon. Enter "stop" to stop. 
G5;G6 
Shortest path between identified persons: 
G5 is parent of 

G6 

Condensed path: 

G5 is mother of 

G6 
Proportion of common genetic material = 5.62500E-01 

Enter two person-identifiers (name or number), 
separated by semicolon. Enter "stop" to stop, 
stop 
End of relation-finder. 


2.0 ADA 
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■ first compilation-unit #1 is package of global types and objects 

package RELATION TYPES AND DATA is 


constant integer := 300; 
constant integer : = 20; 


MAX_PERS0NS 

NAME_LENGTH 

— every PERSON has a unique 3-digit IDENTIFIER 

IDENTIF IER_LENGTH 

BUFFER LENGTH 


constant integer := 3; 
constant integer := 60; 


subtype NAMEJRANGE 
subtype IDENTIF IER_RANGE 
subtype BUFFER_RANGE 

subtype NAME_TYPE 
subtype BUFFER_TYPE 
subtype MESSAGE_TYPE 

subtype INDEX_TYPE 
subtype COUNTER 
subtype DIGIT TYPE 


is integer range l..NAME_LENGTH; 

is integer range 1. .IDENTIF IER_LENGTH; 

is integer range 1. .BUFFER_LENGTH; 

is string (NAME_RANGE ) ; 
is string (BUFFER_RANGE) ; 
is string (1..40); 

is integer range 0. .MAX_PERS0NS; 
is integer range 0. .integer' last; 
is character range '0'..'9'; 


type REAL is digits 6; 

type IDENTIF IER_TYPE is array ( IDENTIF IER_RANGE) of DIGITJTYPE; 

— each PERSON'S record in the file identifies at most three 

— others directly related: father, mother, and spouse 

type GIVEN_IDENTIFIERS is (FATHER_IDENT, M0THER_IDENT, SP0USE_IDENT ) ; 
type RELATIVE ARRAY is array (GIVEN IDENTIFIERS) of IDENTIFIER TYPE; 


NULL_IDENT 
REQUEST_0K 

"Request OK 
REQUEST_T0_ST0P 

"stop 


: constant IDENTIF IERJTYPE 
: constant MESSAGE_TYPE 

: constant BUFFER TYPE 


- "000"; 


type GENDERJTYPE 
type RELATION TYPE 


is (MALE, FEMALE); 
_ is (PARENT, CHILD, SPOUSE, SIBLING, UNCLE, 

NEPHEW, COUSIN, NULL_RELATI0N) ; 

— directed edges in the graph are of a given subtype 
subtype EDGE_TYPE is RELATIONJTYPE range PARENT .. SPOUSE ; 

— A node in the graph (= PERSON) has either already been reached, 

— is immediately adjacent to those reached, or farther away, 
type REACHED_TYPE is (REACHED, NEARBY, N0T_SEEN); 

— each PERSON has a linked list of adjacent nodes, called neighbors 
type NEIGHB0R_REC0RD; 

type NEIGHB0R_P0INTER is access NEIGHB0R_REC0RD; 
type NEIGHB0RJREC0RD is 
record 

NEIGHB0R_INDEX : INDEX_TYPE; 
NEIGHB0R_EDGE : EDGEJCYPE; 
NEXT_NEIGHB0R : NEIGHB0R_P0INTER; 
end record; 
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— All relationships are captured in the directed graph of which 

— each record is a node . 
type PERS0N_REC0RD is 

record 

— static information - filled from PEOPLE file: 
NAME : NAME_TYPE; 
IDENTIFIER : IDENTIFIER_TYPE; 
GENDER : GENDERJTYPE; 

— IDENTIFIERS of immediate relatives - father, mother, spouse 
RELATIVE_IDENTIFIER : RELATI VE_ARRAY ; 

— head of linked list of adjacent nodes 
NEIGHBOR_LIST_HEADER : NEIGHBOR_POINTER; 

— data used when traversing graph to resolve user request : 
DISTANCE_FROM_SOURCE 
PATHJPREDECESSOR 
EDGE_TO_PREDECESSOR 
REACHED_STATUS 

— data used to compute common genetic material 
DESCENDANT_IDENTIFIER : IDENTIFIERJTYPE; 
DESCENDANT_GENES : REAL; 

end record; 

— the PERSON array is the central repository of information 

— about inter- relationships . 

PERSON : array (INDEX_TYPE) of PERS0N_REC0RD; 

— utility to truncate or fill with spaces 

procedure COERCE_STRING (SOURCE : in string; TARGET : in out string); 

end RELATION_TYPES_AND_DATA; 
END SPECIFICATION BEGIN BODY 


REAL; 

INDEXJTYPE; 
EDGE_TYPE ; 
REACHED TYPE; 


package body RELATION__TYPES_AND_DATA is 

procedure COERCE_STRING (SOURCE : in string; TARGET : in out string) is 
MANY SPACES : constant string (1..100) := 


begin 

if SOURCE 'length < TARGET 'length then 

TARGET (TARGET' fir St.. TARGET' first + SOURCE' length - 1) := SOURCE; 
TARGET (TARGET'first + SOURCE'length. .TARGET'last) := 
MANY_SPACES ( 1 .. TARGET' length - SOURCE'length); 
else — SOURCE longer than TARGET 

TARGET := SOURCE (SOURCE 'first . .SOURCE 'first + TARGET'length - 1); 
end if ; 
end COERCE_STRING; 
end RELATION TYPES AND DATA; 
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new compilat ion-unit #2: main line of execution RELATE 

with RELATION_TYPES_AND_DATA, text_io, sequent ial_io; 
use RELATION_TYPES_AND_DATA, text_io; 

procedure RELATE is 

— this is the format of records in the file to be read in 
type FILE_GENDER is ('M', 'F'); 

type FILE_PERSON_RECORD is 
record 

NAME : NAME_TYPE; 

IDENTIFIER : IDENTIFIER_TYPE; 

— 'M' for MALE and 'F' for FEMALE 

GENDER : FILE_GENDER; 

RELATIVE_IDENTIFIER : RELATIVE_ARRAY; 
end record; 

— Instantiate generic package for file 10. 
package PE0PLE_I0 is 

new sequent ial_io (ELEMENTJTYPE => FILE_PERSON_RECORD); 

— These variables are used when establishing the PERSON array 

— from the PEOPLE file. 

PEOPLE : PE0PLE_I0 . FILE_TYPE; 

PE0PLE_REC0RD : FILE_PERSON_RECORD; 
CURRENT, NUMBER_OF_PERSONS 

: INDEX_TYPE; 
PREVIOUS_IDENT, CURRENT_IDENT 

: T DENTIFIER_TYPE; 
RELATIONSHIP : GIVEN_IDENTIFIERS; 

— These variables are used to accept and resolve requests for 

— RELATIONSHIP information. 
BUFFER_INDEX, SEMIC0L0N_L0CATI0N 

: BUFFER_RANGE ; 
REQUEST_BUFFER : BUFFER_TYPE; 

PERS0N1_IDENT, PERS0N2_IDENT 

: NAME_TYPE; 
PERS0N1_F0UND, PERS0N2_F0UND 

: COUNTER; 
ERROR_MESSAGE : MESSAGE_TYPE; 

PERS0N1_INDEX, PERS0N2JLNDEX 

: INDEX TYPE; 
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— declare procedures directly invoked from RELATE: 

procedure LINK_RELATIVES (FROM_INDEX : in INDEX_TYPE; 

RELATIONSHIP : in GIVEN_IDENTIFIERS ; 
TO_INDEX : in INDEXJTYPE) 

is separate; 
procedure PROMPT_AND_READ is separate; 

procedure CHECK_REQUEST (REQUEST_STATUS : out MESSAGE_TYPE ; 

SEMICOLONJLOCATION : out BUFFER_RANGE ) 
is separate; 
procedure BUFFER_TO_PERSON (PERSON_ID : in out NAMEJTYPE; 

START_LOCATION, 

STOP_LOCATION : in BUFFER_RANGE ) 
is separate; 
procedure SEARCH_FOR_REQUE STEDJPERSONS 

(PERS0N1_IDENT, PERS0N2_IDENT : in NAMEJTYPE; 
PERS0N1JLNDEX, PERS0N2_INDEX : out INDEXJTYPE; 
PERS0N1_F0UND, PERSON2_FOUND : in out COUNTER) 
is separate; 
procedure FINDJLELATIONSHIP ( TARGE TJLNDEX, SOURCE_INDEX : in INDEXJTYPE) 
is separate; 

— *** execution of main sequence begins here *** — 

begin 

PEOPLE_IO . open (PEOPLE, PEOPLE_IO . IN_FILE, "PEOPLE.DAT"); 

— CURRENT location in array being filled 
CURRENT := 0; 

— This loop reads in the PEOPLE file and constructs the PERSON 

— array from it ( one PERSON = one record = one array entry) . 

— As records are read in, links are constructed to represent the 

— PARENT-CHILD or SPOUSE RELATIONSHIP. The array then implements 

— a directed graph which is used to satisfy subsequent user 

— requests. The file is assumed to be correct - no validation 

— is performed on it . 
READ_IN_PE0PLE: 

while not PEOPLE J.0 . end_of_file (PEOPLE) loop 
PE0PLE_I0 . read (PEOPLE, PE0PLE_REC0RD); 
CURRENT := CURRENT+1; 

— copy direct information from file to array 

PERSON (CURRENT) . NAME := PE0PLE_REC0RD . NAME; 
PERSON (CURRENT) . IDENTIFIER := PE0PLE_REC0RD . IDENTIFIER; 
if PEOPLEJRECORD . GENDER = 'M' then 

PERSON (CURRENT) . GENDER :=MALE; 
else 

PERSON (CURRENT) . GENDER := FEMALE; 
end if ; 

PERSON (CURRENT) . RELATIVE J1DENTIFIER : = 
PE0PLE_REC0RD . RELATIVE_IDENTIFIER; 

— Location of adjacent persons as yet undetermined 
PERSON (CURRENT) . NEIGHBOR JLISTJIEADER := null; 

— Descendants as yet undetermined 

PERSON (CURRENT) . DESCENDANT_IDENTIFIER := NULL_IDENT; 
CURRENT IDENT := PERSON (CURRENT) . IDENTIFIER; 
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— Compare this PERSON against all previously entered PERSONS 

— to search for RELATIONSHIPS. 
COMPARE_TO_PREVIOUS : 

for PREVIOUS in 1. .CURRENT-1 loop 

PREVIOUS_IDENT := PERSON (PREVIOUS) . IDENTIFIER; 
RELATIONSHIP := FATHER_IDENT ; 

— Search for father, mother, or spouse relationship in 

— either direction between this and PREVIOUS PERSON. 

— Assume at most one RELATIONSHIP exists. 
TRY_ALL_RELATIONSHIPS : 

loop 

if PERSON (CURRENT) . RELATIVE_IDENTIFIER (RELATIONSHIP) = 

PREVIOUS_IDENT 
then 

LINK_RELATIVES (CURRENT, RELATIONSHIP, PREVIOUS); 
exit TRY_ALL_RELATIONSHIPS ; 
else 

if CURRENT_IDENT = 

PERSON (PREVIOUS) . RELATIVE_IDENTIFIER (RELATIONSHIP) 
then 

LINK_RELATIVES (PREVIOUS, RELATIONSHIP, CURRENT); 
exit TRY_ALL_RELATIONSHIPS ; 
end if; 
end if ; 
if RELATIONSHIP < SPOUSE_IDENT then 

RELATIONSHIP : = GI VEN_IDENTIF IERS ' succ ( RELATIONSHIP ) ; 
else 

exit TRY_ALL_RELATIONSHIPS ; 
end if ; 
end loop TRY_ALL_RELATIONSHIPS ; 
end loop COMPARE_TO_PREVIOUS ; 
end loop READ_IN_PEOPLE ; 
NUMBER_OF_PERSONS := CURRENT; 
PEOPLEJCO . close (PEOPLE); 

— PERSON array is now loaded and edges between immediate relatives 

— (PARENT-CHILD or SPOUSE -SPOUSE) are established. 

— While-loop accepts requests and finds RELATIONSHIP (if any) 

— between pairs of PERSONS. 
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READ_AND_PROCESS_REQUE ST : 
loop 

PROMPT_AND_READ; 
exit READ_AND_PROCESS_REQUEST when REQUEST_BUFFER = REQUEST_TO_STOP; 

CHECK_REQUEST (ERROR_MESSAGE, SEMICOLONJLOCATION); 

— Syntax check of request completed. Now either display error 

— message or search for the two PERSONS . 

if ERROR_MESSAGE = REQUEST_OK then 

— Request syntactically correct - 

— search for requested PERSONS. 

buffer_to_person (pers0n1_ident, 1, semicolonjlocation - 1); 

buffer_to_person (pers0n2_ident, semicolonjlocation + 1, bufferjlength); 

search_for_requested_persons (pers0n1_ident, pers0n2_ident, 

personij:ndex, person2j:ndex, 
pers0n1jf ound , pers0n2_f ound ) ; 

if (PERS0N1_F0UND - 1) and (PERS0N2_F0UND = 1) then 

— Exactly one match for each PERSON - proceed to 

— determine RELATIONSHIP, if any. 

if PERS0N1JENDEX = PERS0N2_INDEX then 

put (" & PERSON (PERS0N1_INDEX) . NAME & 

" is identical to "); 
if PERSON (PERS0N1_INDEX) . GENDER = MALE then 

put_line( "himself .") ; 
else 

put_line(" her self .") ; 
end if; 
else 

FINDJRELATIONSHIP (PERS0N1_INDEX, PERS0N2JLNDEX); 
end if; 
else — either not found or more than one found 
if PERS0N1JF0UND = then 

put_line (" First person not found."); 
elsif PERS0N1_F0UND > 1 then 

put_line (" Duplicate names for first person - use" & 
" numeric identifier."); 
end if; 
if PERS0N2_F0UND = then 

put_line (" Second person not found."); 
elsif PERS0N2JF0UND > 1 then 

put_line (" Duplicate names for second person - use" & 
" numeric identifier."); 
end if; 
end if; — processing of syntactically legal request 
else 

put_line (" Incorrect request format: " & ERR0RJ1ESSAGE ) ; 
end if ; 
end loop READ_AND_PROCESS_REQUEST; 
put_line (" End of relation-finder."); 
end RELATE; 
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new compilation-unit #3: procedures under RELATE 

separate (RELATE) 

procedure LINK_RELATIVES (FROM_INDEX : in INDEX_TYPE; 

RELATIONSHIP : in GIVEN_IDENTIF IERS ; 

TO_INDEX : in INDEX_TYPE) is 

— establishes cross-indexing between immediately related PERSONS. 

procedure LINK_ONE_WAY (FROM_INDEX : in INDEX_TYPE; 

THIS_EDGE : in EDGE_TYPE; 
TOJLNDEX : in INDEX_TYPE) is 
— Establishes the NEIGHBOR_RECORD from one PERSON to another 

NEW_NEIGHBOR : NEIGHBOR_POINTER; 

begin 

NEW_NEIGHBOR := new NEIGHBOR_RECORD 
'(NEIGHBOR_INDEX => TO_INDEX, 
NEIGHBOR_EDGE => THIS_EDGE, 

NEXT_NEIGHBOR => PERSON (FROM_INDEX) . NEIGHBOR_LIST_HEADER); 
PERSON (FROM_INDEX) . NEIGHBOR_LIST_HEADER := NEWJNEIGHBOR; 
end; 

begin — execution of LINK_RELATIVES 
if RELATIONSHIP = SPOUSE_IDENT then 

LINK_ONE_WAY (FROM_INDEX, SPOUSE, TO__INDEX); 
LINK_ONE_WAY (TO_INDEX, SPOUSE, FROM_INDEX); 
else — RELATIONSHIP is father or mother 

LINK_ONE_WAY (FROM_INDEX, PARENT, TO_INDEX); 
LINK_ONE_WAY (TO_INDEX, CHILD, FROM_INDEX); 
end if ; 
end LINK_RELATIVES; 

separate (RELATE) 

procedure PROMPT_AND_READ is 

— Issues prompt for user-request, reads in request, 

— blank-fills buffer, and skips to next line of input. 

LAST_FILLED : natural; 

beg in 

put_line (" "); 

put_line (" "); 

put_line (" Enter two person-identifiers (name or number),"); 

put_line (" separated by semicolon. Enter ""stop"" to stop."); 

get~line (REQUEST_BUFFER, LAST_F ILLED ) ; 

COERCE_STRING ( " " , REQUE ST_BUFFER (LAST_F ILLED+1 . . BUFFER_LENGTH ) ) ; 
end PROMPT AND READ; 
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separate (RELATE) 

procedure CHECK_REQUEST (REQUEST_STATUS : out MESSAGE_TYPE; 

SEMICOLON_LOCATION : out BUFFER_RANGE) is 

— Performs syntactic check on request in buffer. 

SEMICOLONJCOUNT : COUNTER; 

PERSONl_F IELD_E XI STS , PERSON2_F IELD_E XI STS 

: boolean; 

begin 

REQUEST_STATUS := REQUEST_OK; 

SEMICOLONJLOCATION := 1; 
PERS0N1_FIELD_EXISTS := false; 
PERSON2_FIELD_EXISTS := false; 
SEMICOLON_COUNT := 0; 
for BUFFER_INDEX in BUFFER_RANGE loop 

if REQUEST_BUFFER (BUFFER_INDEX) /= " ' then 
if REQUEST_BUFFER (BUFFER_INDEX) = ';' then 
SEMICOLONLOCATION := BUFFER_INDEX; 
SEM IC 0L0N_C OUNT : = SEM IC 0L0N_C OUNT + . 1 ; 

else — Check for non-blanks before/after semicolon, 
if SEMICOLON_COUNT < 1 then 

PERS0N1_FIELD_EXISTS := true; 
else 

PERS0N2_FIELD_EXISTS := true; 
end if; 
end if; 
end if ; 
end loop; 

— set REQUEST_STATUS, based on results of scan of REQUESTJBUFFER. 
if SEM ICOLONJC OUNT /= 1 then 

REQUEST_STATUS := "must be exactly one semicolon, 
elsif not PERS0N1_FIELD_EXISTS then 

REQUEST_STATUS := "null field preceding semicolon, 
elsif not PERS0N2_FIELD_EXISTS then 

REQUEST_STATUS := "null field following semicolon, 
end if ; 
end CHECK_REQUEST; 

separate (RELATE) 

procedure BUFFER_TO_PERSON (PERS0N_ID : in out NAME_TYPE; 

START_L0CATI0N, 

ST0P_L0CATI0N : in BUFFER_RANGE ) is 

— fills in the PERS0N_ID from the designated portion 

— of the REQUEST_BUFFER. 

FIRST_NON_BLANK : BUFFER_RANGE ; 

begin 

FIRSTJJONJBLANK := STARTJLOCATION; 

while REQUEST_BUFFER (FIRST_NON_BLANK) = ' ' loop 

FIRST_NON_BLANK := FIRST_NON_BLANK + 1; 
end loop; 

C0ERCE_STRING (REQUEST_BUFFER (FIRST_NON_BLANK. .STOP_LOCATION) , 
PERSONJLD); 
end BUFFER TO PERSON; 
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separate (RELATE) 

procedure SEARCH_FOR_REQUE STED_PERSONS 

(PERS0N1_IDENT, PERS0N2JLDENT 

PERS0N1_INDEX, PERS0N2_INDEX 

PERS0N1_F0UND, PERS0N2_F0UND 

— SEARCH_FOR_REQUESTED_PERSONS scans through the PERSON arr*y f 

— looking for the two requested PERSONS. Match may be by 

— or unique IDENTIF IER-number . 


in NAME_T TIE ; 
out IN®EX_r01| 
in out COUNTER} tm 


THIS IDENT 


NAME TYPE; 


begin 

PERS0N1_F0UND := 

PERS0N2_F0UND := 

PERS0N1_INDEX := 

PERS0N2_INDEX := 
SCAN_ALL_PERSONS : 

for CURRENT in 1. . NUMBER_OF_PERSONS loop 

— THIS_IDENT contains CURRENT PERSON'S numeric IDENCTM 

— left- justified, padded with blanks. 
COERCE_STRING (" ", THIS_IDENT); 

for IDENTIF IER_INDEX in IDENTIF IER_RANGE loop 
THIS_IDENT ( IDENTIF IER_INDEX) : = 

PERSON (CURRENT) . IDENTIFIER (IDENTIF IER_INBEX); 
end loop; 

— allow identification by name or number . 
if (PERS0N1_IDENT = THIS_IDENT) or 

(PERS0N1JLDENT = PERSON (CURRENT) . NAME) 
then 

PERS0N1_F0UND := PERS0N1_F0UND + 1; 

PERS0N1_INDEX := CURRENT; 
end if; 
if (PERS0N2_IDENT - THIS_IDENT) or 

(PERS0N2_IDENT = PERSON (CURRENT) . NAME) 
then 

PERS0N2_FOUND := PERS0N2_F0UND + 1; 

PERS0N2_INDEX := CURRENT; 
end if; 
end loop SCAN_ALL_PERSONS ; 
end SEARCH FOR REQUESTED PERSONS; 
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separate (RELATE) 

procedure FIND_RELATIONSHIP ( TARGE T_INDEX, SOURCE_INDEX : in INDEX_TYPE) is 

— Finds shortest path (if any) between two PERSONS and 

— determines their RELATIONSHIP based on immediate relations 

— traversed in path. PERSON array simulates a directed graph, 

— and algorithm finds shortest path, based on following 

— weights: PARENT -CHILD edge =1.0 

SPOUSE-SPOUSE edge =1.8 

type SEARCH TYPE is (SEARCHING, SUCCEEDED, FAILED); 


SEARCH_STATUS : SEARCHJYPE; 

THIS_NODE, ADJACENT_NODE, BEST_NEARBY_INDEX, LAST_NEARBY_INDEX 

INDEX_TYPE; 

array (INDEX_TYPE) of INDEX_TYPE; 

EDGE_TYPE ; 

NEIGHBOR_POINTER ; 

GIVEN_IDENTIFIERS ; 

REAL; 


NEARBY_NODE 
THIS_EDGE 
THIS_NEIGHB0R 
RELATIONSHIP 
MINIMAL DISTANCE 


procedure PROCESS_ADJACENT_NODE (BASE_N0DE, NEXT_N0DE 

NEXT_BASE_EDGE 

is separate; 
procedure RESOLVE_PATH_TO_ENGLISH is separate; 
procedure C0MPUTE_C0MM0N_GENES (INDEX1, INDEX2 : in INDEX_TYPE) 

is separate; 


in INDEX_TYPE; 
in EDGE TYPE) 


begin — execution of FIND_RELATIONSHIP 

— initialize PERSON-array for processing - 

— mark all nodes as not seen 

for PERSON_INDEX in 1. .NUMBER_0F_PERS0NS loop 

PERSON (PERSON_INDEX) . REACHED_STATUS := NOT_SEEN; 
end loop; 
THIS_N0DE := SOURCE_INDEX; 

— mark source node as REACHED 

PERSON (THIS_N0DE) . REACHED_STATUS := REACHED; 

PERSON (THIS_N0DE) . DISTANCE_FROM_SOURCE := 0.0; 

— no NEARBY nodes exist yet 
LAST_NEARBY_INDEX := 0; 

if THIS_N0DE = TARGET_INDEX then 

SEARCH_STATUS := SUCCEEDED; 
else 

SEARCH_STATUS := SEARCHING; 
end if ; 
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— Loop keeps processing closest-to-source, unREACHED node 

— until target REACHED, or no more connected nodes. 
SEARCH_FOR_TARGET : 

while SEARCH_STATUS = SEARCHING loop 

— Process all nodes adjacent to THIS_NODE 

THIS_NEIGHBOR := PERSON (THIS_NODE) . NEIGHBOR_LIST_HEADER; 
while THIS_NEIGHBOR /= null loop 

PROCESS_ADJACENT_NODE (THIS_NODE, 

THIS_NEIGHBOR . NEIGHBORJLNDEX, 
THIS_NEIGHBOR . NEIGHBOR_EDGE ) ; 
THIS_NEIGHBOR := THIS_NEIGHBOR . NEXT_NEIGHBOR; 
end loop ; 

— All nodes adjacent to THIS_NODE are set. Now search for 

— shortest-distance unREACHED (but NEARBY) node to process next^ 
if LAST_NEARBY_INDEX = then 

SEARCH_STATUS := FAILED; 
else — determine next node to process 
MINIMALJDISTANCE := 1.0e+18; 
for PERSON_INDEX in 1. .LAST_NEARBY_INDEX loop 

if PERSON (NEARBY_NODE (PERSON_INDEX)) . DISTANCE_FROM_SOURCE 

< MINIMALJDISTANCE 
then 

BEST_NEARBY_INDEX := PERSON_INDEX; 
MINIMAL_DISTANCE : = 

PERSON (NEARBY_NODE (PERSON_INDEX)) . DISTANCE_FROM_SOURCE; 
end if ; 
end loop; 

— establish new THIS_NODE 

THIS_NODE := NEARBY_NODE (BEST_NEARBY_INDEX) ; 

— change THIS_NODE from being NEARBY to REACHED 
PERSON (THIS_NODE) . REACHED_STATUS := REACHED; 

— remove THIS_NODE from NEARBY list 

NEARBY_NODE (BEST_NEARBY_INDEX) := NEARBY_NODE (LAST_NEARBY_INDEX) ; 
LAST_NEARBY_INDEX := LAST_NEARBY_INDEX - 1; 
if THIS_NODE = TARGET_INDEX then 

SEARCH_STATUS := SUCCEEDED; 
end if ; 
end if ; 
end loop SEARCH_FOR_TARGET ; 

— Shortest path between PERSONS now established. Next task is 

— to translate path to English description of RELATIONSHIP. 

if SEARCH_STATUS = FAILED then 

put_line (' ' & PERSON ( TARGE T_INDEX) . NAME & " is not related to " « 
PERSON (SOURCE_INDEX) . NAME); 
else — success - parse path to find and display RELATIONSHIP 
RE SOL VE_P ATH_TO_ENGLI SH ; 

COMPUTE_COMMON_GENES (SOURCE_INDEX, TARGE T_INDEX); 
end if; 
end FIND RELATIONSHIP; 
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new compilation-unit #4: procedures under FIND_RELATIONSHIP 

separate (RELATE . FIND_RELATIONSHIP) 

procedure PROCESS_ADJACENT_NODE (BASE_N0DE, NEXT_N0DE : in INDEX_TYPE; 

NEXT_BASE_EDGE : in EDGEJTYPE) is 

— NEXT_N0DE is adjacent to last-REACHED node (= BASE_N0DE). 

— if NEXT_N0DE already REACHED, do nothing. 

— If previously seen, check whether path thru BASE_N0DE is 

— shorter than current path to NEXT_N0DE, and if so re-link 

— next to base . 

— If not previously seen, link next to base node. 

WEIGHT_THIS_EDGE, DISTANCE_THRU_BASE_NODE : REAL; 

procedure LINK_NEXT_NODE_TO_BASE_NODE is 

— link next to base by re-setting its predecessor index to 

— point to base, note type of edge, and re-set distance 

— as it is through base node. 

begin — execution of LINK NEXT NODE TO BASE NODE 


PERSON (NEXT_N0DE) . DISTANCE_FROM_SOURCE 
PERSON (NEXT_N0DE) . PATH_PREDECESSOR 
PERSON (NEXT_N0DE) . EDGE_TO_PREDECESSOR 
end LINK NEXT NODE TO BASE NODE; 


= DISTANCE_THRU_BASE_NODE ; 

= BASE_N0DE; 

= NEXT BASE EDGE; 


begin — execution of PROCESS_ADJACENT_NODE 

if PERSON (NEXT_N0DE) . REACHED_STATUS /= REACHED then 
if NEXT_BASE_EDGE = SPOUSE then 

WEIGHT_THIS_EDGE := 1.8; 
else 

WEIGHT_THIS_EDGE := 1.0; 
end if; 

DISTANCE_THRU_BASE_NODE := WEIGHT_THIS_EDGE + 
PERSON (BASE_N0DE) . DISTANCE_FROM_SOURCE; 
if PERSON (NEXTJJODE) . REACHED_STATUS = N0T_SEEN then 
PERSON ( NEXTJJODE) . REACHED_STATUS := NEARBY; 
LAST_NEARBY_INDEX := LAST_NEARBY_INDEX + 1; 
NEARBY_NODE (LAST_NEARBY_INDEX) := NEXT_N0DE; 
LINK_NEXT_N0DE_T0_BASE_N0DE ; 
else — REACHED_STATUS = NEARBY 
if DISTANCE_THRU_BASE_NODE 

< PERSON (NEXT_N0DE) . DISTANCE_FROM_SOURCE 
then 

LINK_NEXT_NODE_TO_BASE_NODE ; 
end if; 
end if ; 
end if ; 
end PROCESS ADJACENT NODE; 
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separate (RELATE . FIND_RELATIONSHIP) 
procedure RESOLVE_PATH_TO_ENGLISH is 

— RESOLVE_PATH_TO_ENGLISH condenses the shortest path to a 

— series of RELATIONSHIPS for which there are English 

— descriptions. 

— Key persons are the ones in the RELATIONSHIP path which remain 

— after the path is condensed. 

type SIBLING JTYPE is (STEP, HALF, FULL); 

type KEY_PERSON_RECORD ( RELATION JTO_NEXT : RELATION_TYPE := PARENT) is 
record 

PERSON_INDEX : INDEXJTYPE; 
GENERATION_GAP : COUNTER; 
PROXIMITY : SIBLINGJTYPE; 

case RELATION_TO_NEXT is 

when COUSIN => COUSIN_RANK : COUNTER; 
when others => null; 
end case; 
end record; 

— these variables are used to generate KEY_PERSONs 
GENERATION_COUNT : COUNTER; 
THIS_COUSIN_RANK : COUNTER; 
THIS_PROXIMITY : SIBLINGJTYPE; 

— these variables are used to condense the path 

KEY_PERSON : array (INDEXJTYPE) of KEY_PERSON _RECORD ; 

KEY_RELATION, LATER_KEY_RELATION, PRIMARYJtELATION, 

NEXT_PRIMARY_RELATION : RELATION JTYPE ; 
KEY_INDEX, LATER _KE Y_INDEX, PRIMARY_INDEX 

: INDEXJTYPE; 
ANOTHER_ELEMENT_POSSIBLE : boolean; 

function FULL_SIBLING (INDEX1, INDEX2 : in INDEXJTYPE) 

return boolean is 

— Determines whether two PERSONS are full siblings, i.e., 

— have the same two parents . 
begin 

return 

PERSON (INDEX1) . RELATIVE_IDENTIFIER (FATHER_IDENT) /= NULL_IDENT and 
PERSON (INDEX1) . RELATIVE_IDENTIFIER (MOTHER_IDENT) /= NULL_IDENT and 
PERSON (INDEX1) . RELATIVE_IDENTIFIER (FATHER_IDENT) = 

PERSON (INDEX2) . RELATIVE_IDENTIFIER (FATHER_IDENT) and 
PERSON (INDEX1) . RELATIVE_IDENTIFIER (MOTHERJEDENT) - 

PERSON (INDEX2) . RELATIVE__IDENTIFIER (MOTHER_IDENT); 
end FULL SIBLING; 
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procedure CONDENSE_KEY_PERSONS (ATJNDEX : in INDEX_TYPE; 

GAP_SIZE : in COUNTER) is 

— CONDENSE_KEYJPERSONS condenses superfluous entries from the 

— KEY_PERSON array, starting at AT_INDEX. 

RECEIVE_INDEX, SEND_INDEX : INDEX_TYPE; 

begin 

RECEIVE_INDEX := AT_INDEX; 
loop 

RECEIVE_INDEX := RECEIVE_INDEX + 1; 
SEND_INDEX := RECEIVE_INDEX + GAP_SIZE; 

KEY_PERSON (RECEIVE_INDEX) := KEY_PERSON (SENDJLNDEX); 
exit when KEY_PERSON (SEND_INDEX) . RELATION_TO_NEXT = NULL_RELATION ; 
end loop; 
end CONDENSE_KEY_PERSONS ; 

procedure DISPLAY_RELATION (FIRSTJLNDEX, LAST_INDEX, PRIMARY_INDEX 

: in INDEX_TYPE) 
is separate; 

begin — execution of RESOLVE_PATH_TO_ENGLISH 

put_line (" Shortest path between identified persons: " ); 
THIS_NODE := TARGET_INDEX; 
KEY_INDEX :- 1; 

— Display path and initialize KEY_PERSON array from path elements. 
TRAVERSE_SHORTEST_PATH : 

while THIS_NODE /= SOURCE_INDEX loop 

put (' ' & PERSON (THIS_NODE) . NAME & " is "); 
case PERSON (THIS_NODE) . EDGE_TO_PREDECESSOR is 
when PARENT => 

put_line ("parent of"); 
KEY_PERSON (KEY_INDEX) : = 

(PERSON_INDEX => THIS_NODE, 

GENERATION_GAP => 1, 
PROXIMITY => FULL, 

RELATION_TO_NEXT => PARENT); 
when CHILD => 

put_line ("child of"); 
KEY_PERSON (KEYJLNDEX) := 

(PERSON_INDEX => THIS_NODE, 

GENERATION_GAP => 1, 
PROXIMITY => FULL, 

RELATION_TO_NEXT => CHILD); 
when SPOUSE => 

put_line ("spouse of"); 
KEY_PERSON (KEY_INDEX) : = 

(PERSON_INDEX => THISJJODE, 

GENERATION_GAP => 0, 
PROXIMITY => FULL, 

RELATI0N_T0_NEXT => SPOUSE); 
end case; 

KEY_INDEX := KEY_INDEX + 1; 

THIS_N0DE := PERSON (THIS_N0DE) . PATH_PREDECESSOR; 
end loop TRAVERSE SHORTEST PATH; 
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put_lineC ' & PERSON (THIS_NODE) . NAME); 
KEYJPERSON (KEY_INDEX) := 

(PERSON_INDEX => THIS_NODE, 

GENERATIONJ3AP => 0, 

PROXIMITY => FULL, 

RELATION_TO_NEXT => NULL_RELATION); 
KEY_PERSON (KEY_INDEX + 1) : = 
(PERSON_INDEX => 0, 

GENERATI0N_GAP => 0, 

PROXIMITY => FULL, 

RELATION_TO_NEXT => NULL_RELATION ) ; 

— Resolve CHILD-PARENT and CHILD-SPOUSE-PARENT relations 

— to SIBLING relations. 
KEY_INDEX := 1; 

FIND_SIBLINGS: 

while KEY_PERSON (KEY_INDEX) . RELATION_TO_NEXT /= NULL_RELATION loop 
if KEY_PERSON (KEY_INDEX) . RELATION_TO_NEXT = CHILD then 

LATER_KEY_RELATION := KEY_PERSON (KEY_INDEX + 1) . RELATION_TO_NEXT ; 
if LATER_KEY_RELATION = PARENT then 

— found either full or half SIBLINGS 

if FULL_SIBLING (KEY_PERS0N (KEY_INDEX) . PERS0N_INDEX, 

KEY_PERS0N (KEY_INDEX + 2) . PERSON J!NDEX) 
then 

THIS_PROXIMITY := FULL; 
else 

THIS PROXIMITY := HALF; 
end if; * 
KEYJPERSON (KEYJ1NDEX) : = 

(PERSON JENDEX => KEYJ>ERSON (KEYJ!NDEX) . PERSON J!NDEX, 

GENERATION_GAP => 0, 
PROXIMITY => THISJPROXIMITY, 

RELATIONJTO_NEXT => SIBLING); 
CONDENSE_KEYJPERSONS (KEYJNDEX, 1); 
elsif (LATER_KEY_RELATION = SPOUSE) and 

(KEYJ>ERSON (KEYJINDEX + 2) . RELATION JTO_NEXT = PARENT) 
then — found step-SIBLINGs 
KEYJ>ERSON (KEYJINDEX) : = 

(PERSON JINDEX => KEYJ>ERSON (KEYJINDEX) . PERSON J!NDEX, 

GENERATIONJGAP => 0, 
PROXIMITY => STEP, 

RELATION JT0_NEXT => SIBLING); 
CONDENSE J0EYJ>ERSONS (KEYJNDEX, 2); 
end if; — LATER JCEYJtELATION = PARENT 
end if; — RELATION J?0_NEXT = CHILD 
KEY_INDEX := KEYJINDEX + 1; 
end loop FIND SIBLINGS; 
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lft#0&ve CHILD-CHILD-. . . and PARENT-PARENT 
#i*«6t descendant or ancestor relations. 
immx : = 1; 

§R_DESCENDANTS: 
Kt_fERSON (KEY_INDEX) 
it <«fcr_fttSQN (KEY_INDEX) 
tmn PERSON (KEY INDEX) 


relations to 


RELATION_TO_NEXT /= NULL_RELATION loop 
RELATION_TO_NEXT - CHILD) or 
RELATION TO NEXT = PARENT) 


L*THy®Y_INDEX := KEY_INDEX + 1; 

*fclle KEY_PERSON (LATER_KEY_INDEX) . RELATION_TO_NEXT = 

KEY_PERSON (KEYJLNDEX) . RELATION_TO_NEXT loop 

LATER_KEY_INDEX := LATER_KEY_INDEX + 1; 
tai ieop; 

«W«ftATION_COUNT := LATER_KEY_INDEX - KEY_INDEX; 
K fflKIBRATION_COUNT > 1 then — compress generations 

«Y PERSON (KEY_INDEX) . GENERATION_GAP := GENERATION_COUNT ; 

©WiENSEJKEYJPERSONS (KEY_INDEX, GENERATION^ OUNT - 1); 
^^ if* 

I if J — if RELATION_TO_NEXT - CHILD or PARENT 
:= KEY_INDEX +1; 
IIS© ANCESTORS OR DESCENDANTS; 
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— Resolve CHILD-SIBLING-PARENT to COUSIN, 


CHILD-SIBLING 
SIBLING-PARENT 

KEY_INDEX := 1; 
F IND_COUSINS_NEPHEWS_UNCLES : 

while KEY PERSON (KEY INDEX) 


to NEPHEW, 
to UNCLE. 


GENERATION_GAP 
GENERATION GAP 


GENERATION GAP; 


_ RELATION_TO_NEXT /= NULL_RELATION loop 

LATER_KEY_RELATION := KEY_PERSON (KEY_INDEX + 1) . RELATION_TO_NEXT ; 
if (KEY_PERSON (KEY_INDEX) . RELATION_TO_NEXT = CHILD) and 

(LATER_KEY_RELATION = SIBLING) 
then — COUSIN or NEPHEW 

if KEY_PERSON (KEY_INDEX + 2) . RELATION_TO_NEXT *= PARENT then 
— found COUSIN 
if KEY_PERSON (KEYJENDEX) 

KEY_PERSON (KEY_INDEX + 2) 
then 

THIS_COUSIN_RANK := 

KEYJPERSON (KEY_INDEX) _ 

else 

THIS_COUSIN_RANK := 

KEY_PERSON (KEY_INDEX + 2) . GENERATION_GAP; 
end if; 
KEY_PERSON (KEY_INDEX) := 

(PERSONJNDEX => KEY_PERSON (KEY_INDEX) _ 

GENERATIONJGAP => 

abs (KEY_PERSON (KEY_INDEX) . GENERATION_GAP - 

KEY_PERSON (KEY_INDEX + 2) . GENERATION_GAP ) , 
PROXIMITY => KEY_PERSON (KEY_INDEX + 1) . PROXIMITY, 

RELATION_TO_NEXT => COUSIN, 
COUSIN_RANK => THIS_COUSIN_RANK); 

CONDENSE_KEY_PERSONS (KEY_INDEX, 2); 
else — found NEPHEW 

KEY_PERSON (KEY_INDEX) : = 

(PERSON_INDEX => KEY_PERSON (KEY_INDEX) 

GENERATIONJGAP => KEY_PERSON (KEY_INDEX) 
=> KEY PERSON (KEY INDEX + 


PERSON INDEX, 


PROXIMITY 
RELATION_TO_NEXT => NEPHEW); 
CONDENSE_KEY_PERSONS (KEY_INDEX, 1); 
end if ; 
elsif KEY_PERSON (KEY_INDEX) . RELATION_TO_NEXT = SIBLING and 
LATER KEY RELATION = PARENT 


PERSON_INDEX, 
GENERATIONJGAP, 
1) . PROXIMITY, 


then — found UNCLE 

KEY_PERSON (KEY_INDEX) 
(PERSON_INDEX 
GENERATIONJSAP 
PROXIMITY 
RELATION JTO_NEXT => UNCLE ) ; 
CONDENSE_KEY_PERSONS (KEY_INDEX, 1); 
end if; 

KEY_INDEX := KEY_INDEX + 1; 
end loop FIND COUSINS NEPHEWS UNCLES; 


=> KEYJPERSON (KEY_INDEX) . PERSON_INDEX, 

=> KEYJPERSON (KEY_INDEX + 1) . GENERATION_GAP, 

=> KEY PERSON (KEY INDEX) . PROXIMITY, 
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— Loop below will pick out valid adjacent strings of elements 
-*- to be displayed. KEY_INDEX points to first element, 

— LATER_KEY_INDEX to last element, and PRIMARY_INDEX to the 

— element which determines the primary English word to be used. 

— Associativity of adjacent elements in condensed table 

— is based on English usage* 
KEY_INDEX := 1; 

put_line (" Condensed path:"); 
CONSOLIDATE_ADJACENT_PERSONS: 

while KEY_PERSON (KEY_INDEX) . RELATION_TO_NEXT /= NULL_RELATION loop 

KEY_RELATION := KEY_PERSON (KEY_INDEX) . RELATION_TO_NEXT; 

LATER__KEY_INDEX := KEY_INDEX; 

PRIMARY_INDEX := KEY_INDEX; 

if KEY_PERSON (KEY_INDEX + 1) . RELATION_TO_NEXT /= NULL_RELATION then 

— seek multi-element combination 
ANOTHER_ELEMENT_POSSIBLE := true; 
if KEY_RELATION = SPOUSE then 

IATER_KEY_INDEX := LATER_KEY_INDEX + 1; 

PRIMARY_INDEX := LATER_KEY_INDEX; 

if (KEY_PERSON (LATER_KEY_INDEX) . RELATION_TO_NEXT = SIBLING) or 

(KEY_PERSON (LATER_KEY_INDEX) . RELATION_TO_NEXT = COUSIN) 
then — Nothing can follow SPOUSE-SIBLING or SPOUSE-COUSIN 

ANOTHER_ELEMENT_POSSIBLE := false; 
end if ; 
end if; 

— PRIMARY_INDEX is now correctly set. Next if-statement 

— determines if a following SPOUSE relation should be 

— appended to this combination or left for the next 

— combination. 

if ANOTHER_ELEMENT_POSSIBLE and 

(KEY_PERSON (PRIMARY_INDEX + 1) . RELATION_TO_NEXT = SPOUSE) 

— Only a SPOUSE can follow a Primary 
then 

— check primary preceding and following SPOUSE. 
PRIMARY_RELATION : = 

KEY_PERSON (PRIMARY_INDEX) . RELATION_TO_NEXT ; 

NEXT_PRIMARY_RELATION : = 

KEY_PERSON (PRIMARY_INDEX + 2) . RELATION_TO_NEXT ; 
if (NEXT_PRIMARY_RELATION = NEPHEW or 
NEXT_PRIMARY_RELATION •- COUSIN or 
NEXT_PRIMARY_RELATION = NULL_RELATION) 
or (PRIMARY_RELATION = NEPHEW) 
or ( (PRIMARY_RELATION = SIBLING or 
PRIMARY_RELATION = PARENT) 
and NEXT_PRIMARY_RELATION /= UNCLE ) 
then — append following SPOUSE with this combination. 

LATER_KEY_INDEX := LATER_KEY_INDEX + 1; 
end if; 
end if; 
end if; — multi-element combination 

DISPLAY_RELATION (KEY_INDEX, LATER_KEY_INDEX, PRIMARY_INDEX ) ; 
KEY_INDEX := LATER_KEY_INDEX + 1; 
end loop CONSOLIDATE_ADJACENT_PERSONS ; 

put_line (' ' & PERSON (KEY_PERSON (KEY_INDEX) . PERSON_INDEX) . NAME); 
end; — RESOLVE PATH TO ENGLISH 
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new compilation-unit #5: procedures under RESOLVE_PATH_TO_ENGLISH 

separate (RELATE . FIND_RELATIONSHIP . RESOLVE_PATH_TO_ENGLISH) 
procedure DISPLAY_RELATION (FIRST_INDEX, LAST_INDEX, PRIMARY_INDEX 

: in INDEX_TYPE) is 

— DISPLAY_RELATION takes 1, 2, or 3 adjacent elements in the 

— condensed table and generates the English description of 

— the relation between the first and last + 1 elements . 

INLAW : boolean ; 

THISJPROXIMITY : SIBLING_TYPE ; 

THIS_GENDER : GENDER_TYPE ; 

FIRSTJRELATION, LAST_RELATION, PRIMARY_RELATION 

: RELATIONJTYPE ; 
THIS_GENERATION_GAP, THIS_COUSIN_RANK 

: COUNTER; 

— need to instantiate package to display integer values 
package COUNTER_IO is 

new integer io (COUNTER); 
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begin — execution of DISPLAY RELATION 


FIRST_RELATION 
LAST_RELATION 
PRIMARY RELATION 


RELATION_TO_NEXT ; 
RELATION_TO_NEXT ; 
RELATION TO NEXT; 


: = KEY_PERSON ( F IRST_INDEX) 
:= KEY_PERSON (LAST_INDEX) 
_ := KEY_PERSON (PRIMARY_INDEX) 

— set THIS_PROXIMITY 

if ( (PRIMARY_RELATION - PARENT) and (FIRST_RELATION - SPOUSE)) or 

((PRIMARY_RELATION = CHILD) and (LAST_RELATION = SPOUSE)) 
then 

THIS_PROXIMITY := STEP; 
elsif PRIMARY_RELATION - SIBLING or 
PRIMARY_RELATION = UNCLE or 
PRIMARY_RELATION = NEPHEW or 
PRIMARYJRELATION = COUSIN 
then 

THISJPROXIMITY : = KEY_PERSON (PRIMARY_INDEX) . PROXIMITY; 
else 

THIS_PROXIMITY := FULL; 
end if; 

— set THIS_GENERATION_GAP 

if PRIMARY_RELATION = PARENT or 

PRIMARY_RELATION = CHILD or 

PRIMARY_RELATION = UNCLE or 

PRIMARY_RELATION = NEPHEW or 

PRIMARYJRELATION = COUSIN 
then 

THIS_GENERATION_GAP := KEY_PERSON (PRIMARY_INDEX) 
else 

THIS_GENERATION_GAP := 0; 
end if ; 

— set INLAW 
INLAW := false; 
if (FIRSTJtELATION = SPOUSE) and 

(PRIMARY_RELATION = SIBLING or 
PRIMARY_RELATION = CHILD or 
PRIMARYJRELATION = NEPHEW or 
PRIMARY_RELATION = COUSIN) 
then 

INLAW := true; 
elsif (LASTJtELATION = SPOUSE) and 

(PRIMARYJRELATION - SIBLING or 
PRIMARY_RELATION = PARENT or 
PRIMARYJRELATION = UNCLE or 
PRIMARY _RELATI0N = COUSIN) 
then 

INLAW := true; 
end if; 

— set THISj:OUSIN_RANK 
if PRIMARY JtELATION = COUSIN then 

THISjSOUSINJtANK := KEYJ>ERS0N (PRIMARY_INDEX) 
end if; 


GENERATION GAP; 


COUSIN RANK; 
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— parameters are set - now generate display. 

put (" " & PERSON (KEY_PERSON (FIRST_INDEX) . PERSON_INDEX) . NAME & 

" is "); 

If PRIMARY_REIATION = PARENT or 
PRIMARY_RELATION = CHILD or 
PRIMARY_RELATION = UNCLE or 
PRIMARY_RELATION = NEPHEW 
then 

— display generation-qualifier 
if THISJGENERATIONJGAP >= 3 then 
put ("great"); 

if THIS_GENERATION_GAP > 3 then 
put ("*"); 

COUNTER_IO . put (THIS_GENERATION_GAP - 2, width => 1); 
end if; 
put ("-"); 
end if ; 
if THIS_GENERATION_GAP >= 2 then 

put ("grand-"); 
end if; 
elsif (PRIMARY_RELATION = COUSIN) and then (THIS_COUSIN_RANK > 1) then 
COUNTER_IO . put (THIS_COUSIN_RANK, width => 1); 
case THIS_COUSIN_RANK mod 10 is 
when 1 => put ("st ") 
when 2 => put ("nd "). 
when 3 => put ("rd ") 
when others => put ("th "). 
end case; 
end if; 

if THIS_PROXIMITY = STEP then 

put ("step-"); 
elsif THIS_PROXIMITY = HALF then 

put ("half-"); 
end if; 
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THISJ3ENDER := PERSON (KEYJPERSON (FIRST_INDEX) 
case PRIMARYJRELATION is 

when PARENT => if THIS_GENDER = MALE then put 

else put 

end if; 
when CHILD => if THIS_GENDER = MALE then put 

else put 

end if; 
when SPOUSE => if THIS_GENDER - MALE then put 

else put 

end if; 
when SIBLING => if THIS_GENDER = MALE then put 

else put 

end if; 
when UNCLE => if THIS_GENDER = MALE then put 

else put 

end if; 
when NEPHEW => if THIS_GENDER = MALE then put 

else put 

end if; 
when COUSIN => put ("cousin"); 
when others => put ("null"); 
end case; 


PERS0N_INDEX) . GENDER; 

"father"); 
"mother"); 

"son") ; 
"daughter") ; 

"husband"); 
"wife"); 

"brother"); 
"sister"); 

"uncle"); 
"aunt"); 

"nephew") ; 
"niece"); 


if INLAW then 

put ( "-in-law" ) ; 
end if; 

if (PRIMARY_RELATION = COUSIN) and (THIS_GENERATION_GAP > 0) then 
if THIS_GENERATION_GAP > 1 then 
put (" "); 

C0UNTER_I0 . put (THIS_GENERATION_GAP, width => 1); 
put (" times removed"); 
else 

put (" once removed"); 
end if; 
end if; 


put_line (" of"); 
end DISPLAY RELATION; 
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new compilation-unit #6: procedures under FIMJRELATIONSHIP 

separate (RELATE . FIND_RELATIONSHIP) 

procedure C0MPUTE_COMMON_GENES (INDEX1, INDEX2 : in INDEXJTYPE) is 

— COMPUTE_COMMON_GENES assumes that each ancestor contributes 

— half of the genetic material to a PERSON. It finds common 

— ancestors between two PERSONS and computes the expected 

— value of the PROPORTION of common material. 

COMMON_PROPORTION : REAL; 

package REAL_IO is 
new FLOATJO (REAL); 

procedure ZERO_PROPORTION (ZERO_INDEX : in INDEXJTYPE) is 

— ZERO_PRO PORTION recursively seeks out all ancestors and 

— zeros them out . 

THIS_NEIGHBOR : NEIGHBOR_POINTER; 

begin 

PERSON (ZERO_INDEX) . DESCENDANT_GENES := 0.0; 
THIS_NEIGHBOR := PERSON (ZERO_INDEX) . NEIGHBOR__LIST_HEADER; 
while THIS_NEIGHBOR /= null loop 

if THIS_NEIGHBOR . NEIGHBOR_EDGE = PARENT then 

ZER0JPR0P0RTI0N (THISJJEIGHBOR . NEIGHBORJNDEX); 
end if ; 

THISJJEIGHBOR := THIS_NEIGHBOR . NEXT_NEIGHB0R; 
end loop; 
end ZER0_PR0 PORTION; 

procedure MARK_PROPORTION (MARKER : in IDENTIFIERJTYPE; 

PROPORTION : in REAL; 
MARKED_INDEX : in INDEXJTYPE) is 

— MARKJPROPORTION recursively seeks out all ancestors and 

— marks them with the sender's PROPORTION of shared 

— genetic material. This PROPORTION is diluted by one-half 

— for each generation. 

THIS_NEIGHBOR : NEIGHBOR_POlNTER; 

begin 

PERSON (MARKED_INDEX) . DESCENDANT_IDENTIFIER := MARKER; 
PERSON ( MARKED J1NDEX) . DESCENDANTjGENES : = 

PERSON (MARKED_INDEX) . DESCENDANT_GENES + PROPORTION; 
THISJJEIGHBOR := PERSON (MARKED_INDEX) . NEIGHBOR_LIST_HEADER; 
while THISJJEIGHBOR /= null loop 

if THISJJEIGHBOR . NEIGHBOR JIDGE = PARENT then 
MARK_PR0P0RTI0N (MARKER, PROPORTION / 2.0, 

THISJJEIGHBOR . NEIGHBOR J! NDEX) ; 
end if ; 

THISJJEIGHBOR := THISJJEIGHBOR . NEXTJJEIGHBOR; 
end loop; 
end MARK PROPORTION; 
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procedure CHECK_COMMON_PROPORTION 

(COMMON PROPORTION : in out REAL; 


MATCH IDENTIFIER 

: 

in 

IDENTIFIER TYPE; 

PROPORTION 

i 

in 

REAL; 

ALREADY COUNTED 

i 

in 

REAL; 

CHECK INDEX 

: 

in 

INDEX TYPE) is 


— CHECK_COMMON_PROPORTION searches all the ancestors of 

— CHECK_INDEX to see if any have been marked, and if so 

— adds the appropriate amount to COMMON_PROP0RTI0N. 

THIS_NEIGHBOR : NEIGHBOR_POINTER; 
THIS_CONTRIBUTION : REAL; 

begin 

if PERSON (CHECK_INDEX) . DESCENDANT_IDENTIFIER = MATCH_IDENTIFIER then 

— Increment COMMON_PROPORTION by the contribution of 

— this common ancestor, but discount for the contribution 

— of less remote ancestors already counted. 
THIS_CONTRIBUTION := PERSON (CHECKJNDEX) . DESCENDANTJ3ENES 

* PROPORTION; 
COMMONJPRO PORTION := COMMON_PRO PORTION 
+ THIS_CONTRIBUTION - ALREADY_COUNTED; 
else 

THIS_CONTRIBUTION := 0.0; 
end if; 

THIS_NEIGHBOR := PERSON (CHECKJNDEX) . NEIGHBOR_LIST_HEADER; 
while THISJNEIGHBOR /= null loop 

if THIS_NEIGHB0R . NEIGHB0R_EDGE - PARENT then 
CHECK_C0MM0N_PR0 PORTION (C0MM0N_PR0 PORTION, 
MATCH_IDENTIFIER, PROPORTION / 2.0, 
THIS_CONTRIBUTION / 4.0, 
THIS_NEIGHBOR . NEIGHBOR_INDEX); 
end if ; 

THIS_NEIGHBOR := THISJJEIGHBOR . NEXT_NEIGHBOR; 
end loop; 
end CHECK_C0MM0N_PR0P0RTI0N; 

begin — C0MPUTE_C0MM0N_GENES 

— First zero out all ancestors to allow adding. This is necessary 

— because there might be two paths to an ancestor. 
ZER0_PR0P0RTI0N (INDE XI ) ; 

— now mark with shared PROPORTION 

MARK_PR0P0RTI0N (PERSON (INDEX1) . IDENTIFIER, 1.0, INDEX1); 
COMMONJPRO PORTION := 0.0; 
CHECK_C0MM0N_PR0P0RTI0N ( C0MM0N_PR0P0RTI0N , 

PERSON (INDEX1) . IDENTIFIER, 1.0, 0.0, INDEX2); 
put (" Proportion of common genetic material = "); 
REAL_I0 . put (C0MM0N_PR0 PORTION, fore => 1, aft => 5, exp => 3); 
put_line (" "); 
end COMPUTE COMMON GENES; 
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3.0 BASIC 


Because of the unavailability of a standard implementation, the BASIC program 
could not be tested directly. However, a syntactically non-standard version, 
which is believed to be logically equivalent, was tested. 

10000 ! program-unit number 1 

10010 ! 

10020 program RELATE 

10030 ! 

10040 ! declare subs to be used by this program-unit 

10050 ! 

10060 declare external sub FIND_RELATI0NSHIP 

10070 declare sub LINKJRELATIVES, LINK_0NE_WAY, PRGMPT_AND_READ 

10080 declare sub CHECK_REQUEST, SEARCH_FOR_REQUESTED_PERSONS 

10090 ! 

10100 option base 1 

10110 ! 

10120 ! Define global objects 

10130 ! 

10140 data 300 

10150 read MAX_PERSONS 

10160 ! 

10170 data 1, 2 ! for truth values 

10180 read TRUE, FALSE 

10190 ! 

10200 ! each PERSON'S record in the file identifies at most three 

10210 ! others directly related: father, mother, and spouse 

10220 data 1, 2, 3 

10230 read FATHER_IDENT , M0THERJEDENT, SP0USE_IDENT 

10240 ! 

10250 data M, F 

10260 read MALE$, FEMALE $ 

10270 ! 

10280 data 000 

10290 read NULL_IDENT$ 

10300 ! 

10310 data 1, 2, 3, 4, 5, 6, 7, 8 

10320 read PARENT, CHILD, SPOUSE, SIBLING, UNCLE, NEPHEW 

10325 read COUSIN, NULL_RELATION 

10330 ! 

10340 ! A node in the graph (= PERSON) has either already been reached, 

10350 ! is immediately adjacent to those reached, or farther away. 

10360 data 1, 2, 3 

10370 read REACHED, NEARBY, N0T_SEEN 

10380 ! 
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10390 
10400 
10410 
10420 
10430 
10440 
10450 
10460 
10470 
10480 
10490 
10500 
10505 
10510 
10520 
10530 
10540 
10550 
10560 
10570 
10580 
10590 
10600 
10610 
10620 
10630 


! The following data arrays are the central repository of information 

! .about inter-relationships. All relationships are captured in the 

! directed graph of which each record is a node. 

i 

j 

dim 


static information - filled from PEOPLE file: 
NAME$ (300), IDENTIFIER$ (300), GENDER$ (300) 


IDENTIFIER$s of immediate relatives - father, mother, spouse 
RELATIVE IDENTIFIER$ (300,3) 


dim 

i 

j 

dim 

dim 

j 

? 

dim 

dim 
i 

j 

dim 
j 

data 

read 
i 

! end initialization 
l 


pointers to immediate neighbors in graph 

NEIGHB0R_C0UNT (300) 

NEIGHBORJENDEX (300,20), NEIGHB0R_EDGE (300,20) 

data used when traversing graph to resolve user request: 
DISTANCE_FR0M_S0URCE (300), PATH_PREDECESS0R (300) 
EDGE_T0_PREDECESS0R (300), REACHED_STATUS (300) 

data used to compute common genetic material 
DESCENDANT_IDENTIFIER$ (300), DESCENDANT_GENES (300) 

stop, Request OK 

REQUEST TO ST0P$, REQUEST 0K$ 
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10640 

10650 

10660 

& 

10670 

10680 

10690 

10700 

10710 

10720 

10730 

10740 

10750 

10760 

10770 

& 

& 

& 

& 

& 

10780 

10790 

10800 

10810 

10820 

10830 

10840 

10850 

10860 

10870 

10880 

10890 

10900 

10910 

10920 

& 

10930 

10940 

10950 

& 

10960 

10970 

10980 

10990 

11000 

11010 

11020 

11030 

11040 

11050 

11060 

11070 


! begin main line of execution 
i 

open #1: name "PE0PLE.DAT", access input, rectype native, & 
organization sequential 

This loop reads in the PEOPLE file and constructs the person 
array from it (one person = one set of array entries). 
As records are read in, links are constructed to represent the 
PARENT -CHILD or SPOUSE RELATIONSHIP. The array then implements 
a directed graph which is used to satisfy subsequent user 
requests. The file is assumed to be correct - no validation 
is performed on it. 

for CURRENT = 1 to MAX_PERSONS 

read #1, if missing then exit for, & 

with "string*20, string*3, string*l, 3 of string*3": & 
NAME$ (CURRENT), IDENTIFIER$ (CURRENT), GENDER$ (CURRENT), & 
RELATIVE_IDENTIFIER$ (CURRENT, FATHER_IDENT) , & 

RELATIVE_IDENTIFIER$ (CURRENT, M0THER_IDENT ) , & 

RELATIVE_IDENTIFIER$ (CURRENT, S POUSE_IDENT ) 
let NAME$ (CURRENT) = rtrim$ (NAME$ (CURRENT)) 
! Location of adjacent persons as yet undetermined 
let NEIGHB0R_C0UNT (CURRENT) = 
! Descendants as yet undetermined 

let DESCENDANT_IDENTIFIER$ (CURRENT) = NULL_IDENT$ 
let CURRENT_IDENT$ = IDENTIFIER$ (CURRENT) 

! Compare this PERSON against all previously entered PERSONS 
! to search for RELATIONSHIPS, 
for PREVIOUS = 1 to CURRENT - 1 

let PREVI0US_IDENT$ = IDENTIFIER$ (PREVIOUS) 

Search for father, mother, or spouse relationship in 
either direction between this and PREVIOUS person. 
Assume at most one RELATIONSHIP exists, 
for RELATIONSHIP = FATHER_IDENT to SPOUSE_IDENT 

if RELATIVE_IDENTIFIER$ (CURRENT, RELATIONSHIP) & 
= PREVIOUS_IDENT$ then 
call LINK_RELATIVES (CURRENT, RELATIONSHIP, PREVIOUS) 
exit for 
elseif RELATIVE_IDENTIFIER$ (PREVIOUS, RELATIONSHIP) & 
= CURRENT_IDENT$ then 
call LINK_RELATIVES (PREVIOUS, RELATIONSHIP, CURRENT) 
exit for 
end if 
next RELATIONSHIP 
next PREVIOUS 
next CURRENT 

let NUMBER_0F_PERS0NS = CURRENT - 1 
close #1 
j 

! Person arrays are now loaded and edges between immediate relatives 

! (PARENT-CHILD or SPOUSE -SPOUSE) are established. 

i 
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11080 

11090 

11110 

11120 

11130 

11140 

11150 

11160 

11170 

11180 

11190 

11200 

11210 

& 

& 

11220 

11230 

11240 

11250 

11260 

11270 

11280 

11290 

11300 

11310 

11320 

11330 

& 

& 

& 

& 

& 

& 

11340 

11350 

11360 

11370 

11380 

11390 

11400 

11410 

11420 

11430 

11440 

11450 

11460 

11470 

11480 

11490 

11500 

11510 

11520 

11530 

11540 

11550 

11560 


! Do- loop accepts requests and finds relationship (if any) 

! between pairs of PERSONS. 

do 

call PROMPT_AND_READ 

if REQUEST_BUFFER$ = REQUEST_T0_ST0P$ then exit do 

call CHECK_REQUEST (ERR0R_MESSAGE$, PERS0N1_IDENT$, PERS0N2_IDENT$ ) 

Syntax check of request completed. Now either display error 
message or search for the two PERSONS. 

if ERR0R_MESSAGE$ = REQUEST_0K$ then 
! request syntactically correct 

call SEARCH_F0R_REQUESTED_PERS0NS(PERS0N1_IDENT$, PERS0N2_IDENT$, & 

PERS0N1_INDEX, PERS0N2_INDEX, & 
PERS0N1_F0UND , PERS0N2_F0UND ) 
if PERS0N1_F0UND = 1 and PERS0N2_F0UND = 1 then 
! Exactly one match for each PERSON - proceed to 
! determine RELATIONSHIP, if any. 

if PERSON 1_INDEX = PERS0N2_INDEX then 

print " "; NAME$ (PERS0N1_INDEX); " is identical to "; 
if GENDER$ (PERS0N1_INDEX) = MALE$ then 

print "himself." 
else 

print "herself." 
end if 
else 

call FIND_RELATIONSHIP & 

(PERS0N1_JNDEX, PERS0N2_INDEX, NUMBER_OF_PERSONS, & 
NAME$, IDENTIFIER$, GENDER$, RELATIVE_IDENTIFIER$, & 
NEIGHB0R_C0UNT, NEIGHBOR_INDEX, NEIGHBOR_EDGE, & 

DISTANCE_FROM_SOURCE, PATH_PREDECESSOR, & 

EDGE_TO_PREDECESSOR , REACHED_STATUS , & 

DE SCENDANTJDENTIF IER$ , DE SCENDANT_GENES ) 
end if 
else ! either not found or more than one found 
if PERS0N1_F0UND = then 

print " First person not found." 
elseif PERS0N1_F0UND > 1 then 

print " Duplicate names for first person -"; 
print " use numeric identifier." 
end if 
if PERS0N2_F0UND = then 

print " Second person not found." 
elseif PERS0N2_F0UND > 1 then 

print " Duplicate names for second person -"; 
print " use numeric identifier." 
end if 
end if 
else 

print " Incorrect request format: "; ERROR_MESSAGE$ 
end if 
loop 

print " End of relation-finder." 
stop 
j 

! end of main line of execution; internal subs follow 
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11570 

11580 

11590 

11600 

11610 

11620 

11630 

11640 

11650 

11660 

11670 

11680 

11690 

11700 

11710 

11720 

11730 

11740 

11750 

11760 

11770 

11780 

11790 

11800 

11810 

11820 

11830 

11840 

11850 

11860 

11870 

11880 

11890 

11900 

11910 

11920 

11930 

11940 

11950 

& 

11960 

& 

11970 

11980 

11990 

12000 

12010 

12020 

12030 

12040 

12050 

12060 

12070 


T0_INDEX) 
FR0M_INDEX) 

TO_INDEX) 
FROM INDEX) 


j 

sub LINK_REIATIVES (FROM_INDEX, RELATIONSHIP, TO_INDEX) 

! establishes cross- indexing between immediately related PERSONS 

j 

if RELATIONSHIP = SPOUSE_IDENT then 

call LINK_ONE_WAY (FROMJLNDEX, SPOUSE, 

call LINK_ONE_WAY (TOJLNDEX, SPOUSE, 
else ! RELATIONSHIP is father or mother 

call LINK_ONE_WAY (FROM_INDEX, PARENT, 

call LINK_ONE_WAY (T0_INDEX, CHILD, _ 
end if 
end sub 
j 

sub LINK_ONE_WAY (FROM_INDEX, THIS_EDGE, T0_INDEX) 

! Establishes the neighbor entries from one person to another 

j 

let NEXT_NEIGHBOR = NEIGHB0R_C0UNT (EROM_INDEX) + 1 

let NEIGHBOR_COUNT (FR0M_INDEX) = NEXT_NEIGHBOR 

let NEIGHB0R_INDEX (FR0M_INDEX, NEXT_NEIGHBOR) = T0_INDEX 

let NEIGHB0R_EDGE (FR0M_INDEX, NEXT_NEIGHB0R) = THIS_EDGE 

end sub 

j 

sub PR0MPT_AND_READ 

! Issues prompt for user-request, reads in request, 

! blank-fills buffer, and skips to next line of input. 

j 

print 

print " " 

print " Enter two per son- identifiers (name or number)," 

print " separated by semicolon. Enter ""stop"" to stop." 

line input REQUEST_BUFFER$ 

end sub 
j 

sub CHECK_REQUEST (REQUEST_STATUS$, PERSON 1_IDENT$, PERS0N2_IDENT$) 

! Performs syntactic check on request in buffer 

! and fills in identifiers of the two requested persons. 

j 

let SEMIC0LON_LOCATION = pos (REQUEST_BUFFER$, ";") 
let PERS0N1_IDENT$ = ltrim$ (rtrim$ & 

(REQUEST_BUFFER$ (1 : SEMICOLON_L0CATI0N - 1))) 
let PERS0N2_IDENT$ = ltrim$ (rtrim$ & 

(REQUEST_BUFFER$ (SEMIC0L0N_LOCATION + 1 : len (REQUEST_BUFFER$)))) 
if SEMIC0L0N_L0CATI0N = or pos (PERS0N2_IDENT$, "; ") <> then 

let REQUEST_STATUS$ = "must be exactly one semicolon." 
elseif PERS0N1_IDENT$ = "" then 

let REQUEST_STATUS$ = "null field preceding semicolon." 
elseif PERS0N2_IDENT$ - "" then 

let REQUEST_STATUS$ = "null field following semicolon." 
else 

let REQUEST_STATUS$ = REQUEST_OK$ 
end if 
end sub 

! 
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12080 sub SEARCH_FOR_REQUESTED_PERSONS (PERS0N1_IDENT$, PERS0N2_IDENT$, & 

& PERS0N1_INDEX, PERS0N2_INDEX, & 

& PERS0N1_F0UND, PERS0N2_F0UND) 

12090 ! SEARCH_FOR_REQUESTED_PERSONS scans through the PERSON array, 

12100 ! looking for the two requested PERSONS. Match may be by NAME 

12110 ! or unique IDENTIF IER-number 

12120 ! 

12130 let PERS0N1_F0UND = 

12140 let PERS0N2_F0UND = 

12150 let PERS0N1_INDEX = 

12160 let PERS0N2_INDEX = 

12170 for CURRENT = 1 to NUMBER_0F_PERS0NS 

12180 ! allow identification by name or identifier 

12190 if IDENTIFIER$ (CURRENT) = PERSON 1_IDENT$ & 

& or NAME$ (CURRENT) = PERS0N1_IDENT$ then 

12200 let PERS0N1_INDEX = CURRENT 

12210 let PERS0N1_F0UND = PERS0N1_F 0UND + 1 

12220 end if 

12230 if IDENTIFIER$ (CURRENT) = PERS0N2_IDENT$ & 

& or NAME$ (CURRENT) = PERS0N2_IDENT$ then 

12240 let PERS0N2_INDEX = CURRENT 

12250 let PERS0N2_F0UND = PERS0N2_F 0UND + 1 

12260 end if 

12270 next CURRENT 

12280 end sub 

12290 end ! of main program unit - external procedures follow 

12300 ! 
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! program-unit number 2 

j 

external sub FIND_RELATI0NSHIP 

(TARGET_INDEX, S0URCE_INDEX, NUMBER_0F_PERS0NS , 
NAME$ (), IDENTIFIER$ (), GENDER$ (), RELATIVE_IDENTIFIER$ (,), 
NEIGHB0R_C0UNT (), NEIGHB0R_INDEX (,), NEIGHB0R_EDGE (,), 
DISTANCE_FROM_SOURCE (), PATHJREDECESSOR (), 
EDGE_T0_PREDECESS0R (), REACHEDJSTATUS (), 
DESCENDANT__IDENTIFIER$ (), DESCENDANT_GENES ()) 

Finds shortest path (if any) between two PERSONS and 
determines their RELATIONSHIP based on immediate relations 
traversed in path. PERSON array simulates a directed graph, 
and algorithm finds shortest path, based on following 
weights: PARENT-CHILD edge =1.0 
SPOUSE -SPOUSE edge =1.8 

declare subs and functions to be used by this program-unit 

declare external sub C0MPUTE_C0MM0N_GENES 

declare sub PR0CESS_ADJACENT_N0DE, LINK_NEXT_N0DE_T0_BASE_N0DE 

declare sub RESOLVE_PATH_TO_ENGLISH, C0NDENSE_KEY_PERS0NS 

declare sub DISPIAY_RELATION 

declare function SIBLING_PR0XIMITY 

i 

option base 1 
f 


Define global objects 


for truth values 


j 

i 

data 300 

read MAX_PERS0NS 
j 

data 1, 2 ! 

read TRUE, FALSE 
j 

! each PERSON'S record in the file identifies at most three 

! others directly related: father, mother, and spouse 

data 1, 2, 3 

read FATHER_IDENT, M0THER_IDENT, SP0USE_IDENT 

j 

data M, F 

read MAXE$, FEMALE $ 

I 

data 000 

read NULL_IDENT$ 

j 

data 1, 2, 3, 4, 5, 6, 7, 8 

read PARENT, CHILD, SPOUSE, SIBLING, UNCLE, NEPHEW 

read COUSIN, NULL_RELATION 
j 

! A node in the graph (= PERSON) has either already been reached, 

! is immediately adjacent to those reached, or farther away. 

data 1, 2, 3 

read REACHED, NEARBY, N0T_SEEN 

i 


Page 40 


12760 
12770 
12780 
12790 
12800 
12810 
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12840 
12850 
12860 
12870 
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13060 
13070 
13080 
13090 
13100 
13110 


data 1, 2, 3 ! values for search status 

read SEARCHING, SUCCEEDED, FAILED 

t 

data 1, 2, 3 ! values for sibling proximity 
read STEP, HALF, FULL 

The following arrays contain information on key persons . 

Key persons are the ones in the RELATIONSHIP path which remain 

after the path is condensed. 


dim 
dim 
i 
j 

dim 
i 


RELATI0N_T0_NEXT (300), PERS0N_INDEX (300), GENERATI0N_GAP (300) 
PROXIMITY (300), COUSIN_RANK (300) 

keeps track of current NEARBY nodes in graph search 
NEARBY NODE (300) 


begin main line of execution of FIND RELATIONSHIP 


initialize PERSON-array for processing - 
mark all nodes as not seen 
for THIS_N0DE = 1 to NUMBER_0F_PERS0NS 

let REACHED_STATUS (THIS_N0DE) = N0T_SEEN 

next THIS_N0DE 
; 

let THIS_N0DE = S0URCE_INDEX 

! mark source node as REACHED 

let REACHED_STATUS (THIS_N0DE) = REACHED 

let DISTANCE_FR0M_S0URCE (THIS_N0DE) = 

! no nearby nodes exist yet 

let LAST_NEARBY_INDEX = 

if THIS_N0DE = TARGET_INDEX then 

let SEARCHJ5TATUS = SUCCEEDED 
else 

let SEARCH_STATUS = SEARCHING 

end if 
i 
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13120 ! Loop keeps processing closest-to-source, unREACHED node 

13130 ! until target REACHED, or no more connected nodes. 

13140 do while SEARCH_STATUS = SEARCHING 

13150 ! Process all nodes adjacent to THIS_N0DE 

13160 for THIS_NEIGHB0R = 1 to NEIGHB0R_C0UNT (THIS_N0DE) 

13170 call PR0CESS_ADJACENT_N0DE (THIS_N0DE, & 

& NEIGHB0R_INDEX (THIS_N0DE, THIS_NEIGHB0R) , & 

& NEIGHB0R_EDGE (THIS_N0DE, THIS_NEIGHB0R)) 

1 3 1 80 next THIS_NE IGHBOR 

13190 ! All nodes adjacent to THIS_N0DE are set. Now search for 

13200 ! shortest-distance unREACHED (but NEARBY) node to process next. 

13210 if LAST_NEARBY_INDEX = then 

13220 let SEARCH_STATUS = FAILED 

13230 else ! determine next node to process 

13240 let MINIMAL_DISTANCE = 1.0E+18 

13250 ! now find closest unreached node 

13260 for THIS_NEARBY_INDEX = 1 to LAST_NEARBY_INDE X 

13270 let NEXT_N0DE = NEARBY_NODE (THIS_NEARBY_INDEX) 

13280 if DISTANCE_FR0M_S0URCE (NEXTJJODE) < MINIMALJDISTANCE then 

13290 let BEST_NEARBY_INDEX = THIS_NEARBY_INDEX 

13300 let MINIMAL_DISTANCE = DISTANCE_FR0M_S0URCE (NEXT_N0DE) 

13310 end if 

13320 next THIS_NEARBY_INDEX 

13330 ! establish new THIS_N0DE 

13340 let THIS_N0DE = NEARBY_NODE (BEST_NEARBY_INDEX) 

13350 ! change THIS_N0DE from being NEARBY to REACHED 

13360 let REACHED_STATUS (THIS_N0DE) = REACHED 

13370 ! remove THIS_N0DE from NEARBY list 

13380 let NEARBY_N0DE (BEST_NEARBY_INDEX) = & 

& NEARBY_NODE (LAST_NEARBY_INDEX) 

13390 let LAST_NEARBY_INDEX = LAST_NEARBY_INDEX - 1 

13400 if THIS_N0DE = TARGET_INDEX then let SEARCH_STATUS = SUCCEEDED 

13410 end if 

13420 loop 

13430 ! 

13440 ! Shortest path between PERSONS now established. Next task is 

13450 ! to translate path to English description of RELATIONSHIP. 

13460 if SEARCH_STATUS = FAILED then 

13470 print " "; NAME$ (TARGET_INDEX); " is not related to "; & 

& NAME$ (S0URCE_INDEX) 

13480 else 

13490 ! success - parse path to find and display RELATIONSHIP 

13500 call RES0LVE_PATH_T0_ENGLISH 

13510 call C0MPUTE_C0MM0N_GENES (S0URCE_INDEX, TARGET_INDEX, & 

& IDENTIFIER$, NEIGHB0R_C0UNT, NEIGHB0R_INDEX, NEIGHB0R_EDGE, & 

& DESCENDANT_IDENTIFIER$, DESCENDANT_GENES) 

13520 end if 

13530 exit sub 

13540 ! 

13550 ! end of main line of execution of FIND_RELATI0NSHIP 

13560 ! 
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sub PROCESS_ADJACENT_NODE (BASE_N0DE, NEXTJJODE, NEXT_BASE_EDGE ) 
NEXT_NODE is adjacent to last-REACHED node (= BASE_N0DE). 
if NEXTJTODE already REACHED, do nothing. 
If previously seen, check whether path thru BASE_N0DE is 
shorter than current path to NEXT_N0DE, and if so re-link 
next to base . 
If not previously seen, link next to base node. 

if NEXT_BASE_EDGE = SPOUSE then 

let WEIGHT_THIS_EDGE =1.8 
else 

let WEIGHT_THIS_EDGE = 1.0 

end if 
i 

if REACHED_STATUS (NEXT_N0DE) O REACHED then 

let DISTANCE_THRU_BASE_NODE & 

= WEIGHT_THIS_EDGE + DISTANCE_FR0M_S0URCE (BASE_N0DE) 
if REACHED_STATUS (NEXT_N0DE) = N0TJSEEN then 
let REACHED_STATUS (NEXT_N0DE) = NEARBY 
let LAST_NEARBY_INDEX = LAST_NEARBY_INDEX + 1 
let NEARBYJJODE (LAST_NEARBY_INDEX) - NEXT_N0DE 
! link next to base by re-setting its predecessor index to 

! point to base, note type of edge, and re-set distance 

! as it is through base node . 

let DISTANCE_FR0M_S0URCE (NEXT_N0DE) = DISTANCE_THRU_BASE_NODE 
PATH PREDECESSOR (NEXT NODE) = BASE NODE 


let _ _ _ 

let EDGE_T0_PREDECESS0R (NEXT_N0DE) = NEXT_BASE_EDGE 
else ! REACHED_STATUS = NEARBY 

if DISTANCE_THRU_BASE_N0DE < DISTANCE_FR0M_S0URCE (NEXT_N0DE) then 
link next to base by re-setting its predecessor index to 
point to base, note type of edge, and re-set distance 
as it is through base node, 
let DISTANCE FROM SOURCE (NEXT_N0DE) 

(NEXT_N0DE) 
(NEXT NODE) 


let PATH_PREDECESSOR 
let EDGE TO PREDECESSOR 


DISTANCE_THRU_BASE_NODE 

BASE_N0DE 

NEXT BASE EDGE 


end if 
end if 
end if 
end sub 
» 
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sub RESOLVE_PATH_TO_ENGLISH 

RES0LVE_PATH_T0_ENGLISH condenses the shortest path to a 
series of RELATIONSHIPS for which there are English 
descriptions. 

Key persons are the ones in the RELATIONSHIP path which remain 
after the path is condensed. 

print " Shortest path between identified persons: " 

let THIS_N0DE = TARGET_INDEX 

! print path and initialize KEY_PERS0N array from path elements, 

! as shortest path is traversed. 

let KEYJLNDEX - 1 

do until THIS_N0DE = S0URCE_INDEX 

let PERS0N_INDEX (KEY_INDEX) = THIS_N0DE 

let PROXIMITY (KEY_INDEX) = FULL 

let RELATI0N_T0_NEXT (KEY_INDEX) = EDGE_T0_PREDECESS0R (THIS_N0DE) 
print " "; NAME$ (THIS_N0DE); tab (23); "is "; 
if EDGE_T0_PREDECESS0R (THISJJODE) = SPOUSE then 
let GENERATI0N_GAP (KEY_INDEX) = 
print "spouse of" 
else 

let GENERATI0N_GAP (KEYJNDEX) = 1 

if EDGE_TO_PREDECESSOR (THIS_N0DE) = PARENT then 

print "parent of" 
else ! edge is child-type 

print "child of" 
end if 
end if 

let KEYJtNDEX = KEY_INDEX + 1 
let THIS_N0DE = PATH_PREDECESS0R (THISJJODE) 
loop 

print " "; NAME$ 
let PERSON INDEX 


(THIS_N0DE ) 
_ (KEY_INDEX) 

let RELATION_TO_NEXT (KEY_INDEX) _ 

let RELATION_TO_NEXT (KEY_INDEX + 1) = NULL_RELATION 
i 


= THISJJODE 

= NULL RELATION 
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14340 ! Resolve CHILD-PARENT and CHILD-SPOUSE-PARENT relations 

14350 ! to SIBLING relations. 

14360 let KEY_INDEX - 1 

14370 do until RELATI0N_T0_NEXT (KEY_INDEX) = NULL_RELATI0N 

14380 if RELATI0N_T0_NEXT (KEY_INDEX) - CHILD then 

14390 let LATER_KEY_RELATI0N = RELATI0N_T0_NEXT (KEY_INDEX + 1) 

14400 if LATER_KEY_RELATION = PARENT then 

14410 ! found either full or half SIBLINGS 

14420 let GENERATI0N_GAP (KEY_INDEX) = 

14430 lefr RELATI0N_T0_NEXT (KEY_INDEX) = SIBLING 

14440 let PROXIMITY (KEY_INDEX) = & 

& SIBLING_PR0XIMITY .(PERS0N_INDEX (KEYJLNDEX) , & 

& PERS0N_INDEX (KEY_INDEX +2)) 

14450 call C0NDENSE_KEY_PERS0NS (KEY_INDEX, 1) 

14460 else 

14470 if LATER_KEY_RELATI0N = SPOUSE and & 

& RELATI0N_T0_NEXT (KEY_INDEX + 2) = PARENT then 

14480 ! found step-siblings 

14490 let GENERATIONJGAP (KEY_INDEX) = 

14500 let RELATION_TO_NEXT (KEY_INDEX) - SIBLING 

14510 let PROXIMITY (KEY_INDEX) = STEP 

14520 call CONDENSE_KEY_PERSONS (KEY_INDEX, 2) 

14530 end if 

14540 end if 

14550 end if 

14560 let KEY_INDEX = KEY__INDEX + 1 

14570 loop 

14580 ! 

14590 ! Resolve CHILD-CHILD-... and PARENT-PARENT-... relations to 

14600 ! direct descendant or ancestor relations. 

14610 let KEY_INDEX - 1 

14620 do until RELATION_TO_NEXT (KEY_INDEX) = NULL_RELATION 

14630 if RELATION_TO_NEXT (KEY_INDEX) - CHILD or & 

& RELATION_TO_NEXT (KEY_INDEX) - PARENT then 

14640 let LATER_KEY_INDEX - KEY_INDEX + 1 

14650 do while RELATION_TO_NEXT (LATER_KEY_INDEX) & 

& - RELATION_TO_NEXT (KEY_INDEX) 

14660 let LATER_KEY_INDEX - LATER_KEY_INDEX + 1 

14670 loop 

14680 let GENERATI0N_C0UNT - LATER_KEY_INDEX - KEY_INDEX 

14690 if GENERATION_COUNT > 1 then ! compress generations 

14700 let GENERATION_GAP (KEY_INDEX) = GENERATION_COUNT 

14710 call CONDENSE_KEY_PERSONS (KEY_INDEX, GENERATION_COUNT - 1) 

14720 end if 

14730 end if 

14740 let KEY_INDEX - KEY_INDEX + 1 

14750 loop 

14760 ! 
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14770 ! Resolve CHILD -SIBLING-PARENT to COUSIN, 

14780 ! CHILD-SIBLING to NEPHEW, 

14790 ! SIBLING-PARENT to UNCLE. 

14800 let KEY_INDEX =1 

14810 do until RELATI0N_T0_NEXT (KEY_INDEX) = NULL_RELATION 

14820 let LATER_KEY_RELATI0N = RELATI0N_T0_NEXT (KEY_INDEX +1) 

14830 if RELATI0N_T0_NEXT (KEY_INDEX) = CHILD & 

& and LATER_KEY_RELATI0N = SIBLING then 

14840 ! found COUSIN or NEPHEW 

14850 if RELATI0N_T0_NEXT (KEY_INDEX + 2) = PARENT then 

14860 ! found cousin 

14870 let GAP1 = GENERATION_GAP (KEY_INDEX) 

14880 let GAP2 = GENERATION_GAP (KEY_INDEX + 2) 

14890 let C0USIN_RANK (KEY_INDEX) = mln (GAP1, GAP2) 

14900 let GENERATI0NJ3AP (KEY_INDEX) = abs (GAP! - GAP2) 

14910 let PROXIMITY (KEY_INDEX) = PROXIMITY (KEY_INDEX + 1) 

14920 let RELATI0N_T0_NEXT (KEY_INDEX) = COUSIN 

14930 call C0NDENSE_KEY_PERS0NS (KEY_INDEX, 2) 

14940 else ! found NEPHEW 

14950 let PROXIMITY (KEY_INDEX) = PROXIMITY (KEY_INDEX + 1) 

14960 let RELATI0N_T0_NEXT (KEY_INDEX) = NEPHEW 

14970 call CONDENSE_KEY_PERSONS (KEY_INDEX, 1) 

14980 end if 

14990 else 

15000 if RELATI0N_T0_NEXT (KEY_INDEX) = SIBLING & 

& and LATER_KEY_RELATI0N = PARENT then 

15010 ! found UNCLE 

15020 let GENERATI0N_GAP (KEYJLNDEX) = & 

& GENERATIONjGAP (KEY_INDEX +1) 

15030 let RELATI0N_T0_NEXT (KEY_INDEX) = UNCLE 

15040 call CONDENSE_KEY_PERSONS (KEY_INDEX, 1) 

15050 end if 

15060 end if 

15070 let KEY_INDEX - KEY_INDEX + 1 

15080 loop 

15090 ! 
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Loop below will pick out valid adjacent strings of elements 
to be printed. KEY_INDEX points to first element, 
LATER_KEY_INDEX to last element, and PRIMARY_INDEX to the 
element which determines the primary English word to be used. 
Associativity of adjacent elements in condensed table 
is based on English usage, 
print " Condensed path:" 
let KEY_INDEX = 1 

do until REIATI0N_T0_NEXT (KEY_INDEX) = NULLJRELATION 
let KEY_RELATI0N = RELATI0N_T0_NEXT (KEY_INDEX) 
let IATER_KEY_INDEX, PRIMARY_INDEX = KEY_INDEX 
if RELATI0N_T0_NEXT (KEY_INDEX + 1) <> NULL_RELATI0N then 
! seek multi-element combination 
let AN0THERJELEMENT_P0SSIBLE = TRUE 
if KEY_RELATION = SPOUSE then 

let LATER_KEY_INDEX = LATER_KEY_INDEX + 1 
let PRIMARY_INDEX = LATER_KEY_INDEX 

if RELATI0N_T0_NEXT (LATER_KEY_INDEX) = SIBLING or & 

RELATI0N_T0_NEXT (LATER_KEY_INDEX) - COUSIN then 

! nothing can follow spouse- sibling or spouse-cousin 
let AN0THER_ELEMENT_P0SSIBLE = FALSE 
end if 
end if 

PRIMARY_INDEX is now correctly set. Next if-statement 
determines if a following SPOUSE relation should be 
appended to this combination or left for the next 
combination. 

if RELATION_TO_NEXT (PRIMARY_INDEX + 1) = SPOUSE and & 

ANOTHER_ELEMENT_POSSIBLE = TRUE then 
! Only a SPOUSE can follow a Primary 
! check primary preceding and following SPOUSE, 
let PRIMARY_RELATI0N = RELATI0N_T0_NEXT (PRIMARY_INDEX) 

let NEXT_PRIMARY_RELATI0N = RELATI0N_T0_NEXT (PRIMARY_INDEX + 2) 
if (NEXT_PRIMARY_RELATI0N = NEPHEW or & 

NEXT_PRIMARY_RELATI0N = COUSIN or & 

NEXT_PRIMARY_RELATI0N = NULLJRELATION) & 

or (PRIMARY_RELATI0N = NEPHEW) & 

or ( (PRIMARY_RELATI0N = SIBLING or & 

PRIMARY_RELATI0N = PARENT) & 

and NEXT_PRIMARY_RELATI0N O UNCLE ) then 
! append following SPOUSE with this combination 
let LATER_KEY_INDEX = LATER_KEY_INDEX + 1 
end if 
end if 
end if ! multi-element combination 

call DISPLAY_RELATI0N (KEY_INDEX, LATER_KEY_INDEX, PRIMARY_INDEX) 
let KEYJENDEX = LATER_KEY_INDEX + 1 
loop 
i 

print " "; NAME$ (PERSON_INDEX (KEY_INDEX)) 

end sub 

! end of RESOLVE_PATH_TO_ENGLISH 

i 
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function SIBLING_PR0XIMITY (INDEX1, INDEX2) 

! Determines whether two PERSONS are full siblings, i.e., 

! have the same two parents. 

if RELATIVE_IDENTIFIER$ (INDEX1, FATHER_IDENT ) <> NULL_IDENT$ and 

RELATIVE_IDENTIFIER$ (INDEX1, MOTHER_IDENT) <> NULL_IDENT$ and 

RELATIVE_IDENTIFIER$ (INDEX1, FATHER_IDENT ) = 

RELATIVE_IDENTIFIER$ (INDEX2, FATHER_IDENT ) and 

RELATIVE_IDENTIFIER$ (INDEX1, MOTHER_IDENT) = 

RELATIVE_IDENTIFIER$ (INDEX2, MOTHER_IDENT ) 

let SIBLING_PROXIMITY = FULL 
else 

let SIBLING_PR0XIMITY = HALF 
end if 

end function ! SIBLING_PR0XIMITY 
j 

sub C0NDENSE_KEY_PERS0NS (AT_INDEX, GAP_SIZE) 

! C0NDENSE_KEY_PERS0NS condenses superfluous entries from the 

! key person array entries, starting at AT_INDEX 

let RECEIVEJLNDEX = AT_INDEX 

do 

let RECEIVE_INDEX = RECEIVEJLNDEX + 1 

let SEND_INDEX = RECEIVE_INDEX + GAP_SIZE 

let RELATION TO NEXT (RECEIVE INDEX) = RELATION TO NEXT (SEND 


& 
& 
& 
& 
& 
then 


let PERS0N_INDEX 
let GENERATI0N_GAP 
let PROXIMITY 
let COUSIN RANK 


(RECEIVE_INDEX) = PERSON_INDEX (SEND 

(RECEIVE_INDEX) = GENERATION_GAP (SEND" 

(RECEIVE_INDEX) = PROXIMITY (SEND* 

(RECEIVE INDEX) = COUSIN RANK (SEND" 


INDEX) 
INDEX) 
INDEX) 
INDEX) 
INDEX) 


loop until RELATION_TO_NEXT (SEND_INDEX) = NULL_RELATION 

end sub 
j 

sub DISPLAYJRELATION (FIRST_INDEX, LASTJLNDEX, PRIMARY_INDEX) 
DISPLAY_RELATION takes 1, 2, or 3 adjacent elements in the 
condensed table and generates the English description of 
the relation between the first and last + 1 elements. 

let FIRST_RELATI0N = RELATI0N_T0_NEXT (FIRSTJNDEX) 

let LAST_RELATION = RELATION_TO_NEXT (LASTJLNDEX) 

let PRIMARY_RELATION = RELATION_TO_NEXT (PRIMARY_INDEX) 
j 

! set THIS_PROXIMITY 

if (PRIMARY_RELATION = PARENT and FIRST_RELATION = SPOUSE) or 
(PRIMARY_RELATION = CHILD and LAST_RELATI0N = SPOUSE) then 
let THIS_PROXIMITY = STEP 
else 

if PRIMARY_RELATION = SIBLING or & 

PRIMARY_RELATION = UNCLE or & 

PRIMARY_RELATION - NEPHEW or & 

PRIMARY_RELATI0N = COUSIN then 
let THIS_PROXIMITY = PROXIMITY (PRIMARY_INDEX) 
else 

let THIS_PROXIMITY = FULL 
end if 

end if 
i 
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16000 ! set THIS_GENERATION_GAP 

16010 if PRIMARY_RELATION = PARENT or & 

& PRIMARY_RELATION = CHILD or & 

& PRIMARY_RELATION = UNCLE or & 

& PRIMARY_RELATION = NEPHEW or & 

& PRIMARY_RELATION = COUSIN then 

16020 let THIS_GENERATI0N_GAP = GENERATI0N_GAP (PRIMARY_INDEX) 

16030 else 

16040 let THIS_GENERATI0N_GAP = 

16050 end if 

16060 ! 

16070 ! set INLAW 

16080 if (FIRSTJtELATION = SPOUSE) and & 

& (PRIMARY_RELATI0N = SIBLING or & 

& PRIMARY_RELATI0N = CHILD or & 

& PRIMARYJRELATION = NEPHEW or & 

& PRIMARY_RELATION = COUSIN) then 

16090 let INLAW = TRUE 

16100 else 

16110 if (LAST_RELATION = SPOUSE) and & 

& (PRIMARY_RELATI0N = SIBLING or & 

& PRIMARY_RELATI0N = PARENT or & 

& PRIMARY_RELATI0N = UNCLE or & 

& PRIMARY_RELATI0N = COUSIN) then 

16120 let INLAW = TRUE 

16130 else 

16140 let INLAW = FALSE 

16150 end if 

16160 end if 

16170 ! 

16180 ! set THIS_C0USIN_RANK 

16190 if PRIMARY_RELATION = COUSIN then 

16200 let THIS_C0USIN_RANK = C0USIN_RANK (PRIMARY_INDEX) 

16210 else 

16220 let THIS_COUSIN_RANK = 

16230 end if 

16240 ! 

16250 ! parameters are set - now generate display. 

16260 ! 

16270 print " "; NAME$ (PERSON_INDEX (FIRST_INDEX)); tab(23); "is 

16280 if PRIMARY_RELATI0N - PARENT or & 

& PRIMARY_RELATION - CHILD or & 

& PRIMARY_RELATI0N = UNCLE or & 

& PRIMARY_RELATION = NEPHEW then 

16290 ! print generation-qualifier 

16300 if THIS_GENERATION_GAP >= 3 then 

16310 print "great"; 

16320 if THIS_GENERATI0N_GAP > 3 then 

16330 print "*"; str$ (THIS_GENERATION_GAP - 2); 

16340 end if 

16350 print "-"; 

16360 end if 

16370 if THIS GENERATION GAP >= 2 then print "grand-"; 
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16380 
16390 
16400 
16410 
16420 
16430 
16440 
16450 
16460 
16470 
16480 
16490 
16500 
16510 
16520 
16530 
16540 
16550 
16560 
16570 
16580 
16590 
16600 
16610 
16620 
16630 
16640 
16650 
16660 
16670 
16680 
16690 
16700 
16710 
16720 
16730 
16740 
16750 
16760 
16770 
16780 
16790 
16800 
16810 
16820 
16830 
16840 
16850 
16860 
16870 
16880 
16890 
16900 
16910 
16920 


elseif PRIMARY_RELATION = COUSIN and THIS_C0USIN_RANK > 1 then 
print str$ (THIS_C0USIN_RANK); 
select case mod (THIS_COUSIN_RANK, 10) 
case 1 

print "st 
case 2 

print "nd 
case 3 

print "rd 
case else 
print "th 
end select 
end if 
i 

if THIS_PROXIMITY = STEP then 

print "step-"; 
elseif THIS_PROXIMITY = HALF then 

print "half-"; 

end if 
i 

let THIS_GENDER$ - GENDER$ (PERSON_INDEX (FIRST_INDEX)) 
select case PRIMARY RELATION 


'father' 


son 


case 1 ! PARENT 

if THIS_GENDER$ = MALE$ then print 
case 2 ! CHILD 

if THIS_GENDER$ = MALE$ then print 
case 3 ! SPOUSE 

if THIS_GENDER$ = MALE$ then print "husband* 
case 4 ! SIBLING 

if THIS_GENDER$ = MALE$ then print "brother" 
case 5 ! UNCLE 

if THIS_GENDER$ = MALE$ then print "uncle"; 
case 6 ! NEPHEW 

if THIS_GENDER$ = MALE$ then print "nephew"; 
case 7 ! COUSIN 

print "cousin"; 


else print "mother"; 
else print "daughter* 
else print "wife"; 
else print "sister"; 
else print "aunt"; 
else print "niece"; 


case else 

print "null"; 
end select 
j 

if INLAW = TRUE then print "-in-law"; 
i 

if PRIMARY_RELATION = COUSIN and THIS_GENERATION_GAP > then 
if THIS_GENERATI0N_GAP > 1 then 

print THIS_GENERATI0N_GAP; "times removed"; 
else 

print " once removed"; 
end if 

end if 
j 

print " of" 
j 

end sub ! end of internal sub DISPLAY_RELATI0N 
end sub ! end of external sub FIND_RELATI0NSHIP 
i 
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16930 

16940 

16950 

& 

& 

16960 

16970 

16980 

16990 

17000 

17010 

17020 

17030 

17035 

17040 

17045 

17050 

17055 

17057 

17060 

17065 

17070 

17075 

17080 

17090 

17100 

17110 

17120 

& 

17130 

& 

17140 

17150 

17160 

17170 

17180 

17190 

17200 

17210 

17220 

17230 

& 

17240 

17250 

17260 

17270 




program-unit number 3 


external sub C0MPUTE_C0MM0N_GENES (INDEX1, INDEX2, IDENTIFIER$ (), & 
NEIGHB0R_C0UNT (), NEIGHBOR_INDEX (,), NEIGHB0R_EDGE (,), & 
DESCENDANT_IDENTIFIER$ (), DESCENDANT_GENES ()) 

C0MPUTE_C0MM0N_GENES assumes that each ancestor contributes 
half of the genetic material to a person. It finds common 
ancestors between two persons and computes the expected 
value of the PROPORTION of common material. 

declare sub ZER0_PR0P0RTI0N, MARKJPR0PORTI0N, CHECK_C0MM0NJPR0P0RTI0N 
I 

option base 1 
j 

data 1, 2, 3, 4, 5, 6, 7, 8 

read PARENT, CHILD, SPOUSE, SIBLING, UNCLE, NEPHEW 

read COUSIN, NULL_RELATI0N 

Begin main line of execution of C0MPUTE_C0MM0N_GENES 

First zero out all ancestors to allow adding. This is necessary 

because there might be two paths to an ancestor, 
call ZER0_PR0P0RTI0N (INDEX1, 0) 
! now mark with shared PROPORTION 

call MARKJPROPORTION (IDENTIFIER$ (INDEX1), 1.0, INDEX1, 0) 
let C0MM0N_PR0 PORTION = 0.0 
call CHE CK_COMM0N_PR0PORTI0N (C0MM0N_PR0P0RTI0N, & 

IDENTIFIER$ (INDEX1), 1.0, 0.0, INDEX2, 0) 
print using " Proportion of common genetic material = #.#####~~~~": & 

C0MM0N_PR0P0RTI0N 
j 

! End main line of execution of C0MPUTE_COMM0N_GENES 
j 

sub ZERO_PROP0RTION (ZER0_INDEX, THIS_NEIGHBOR) 

! ZER0_PR0 PORTION recursively seeks out all ancestors and 
! zeros them out 
let DESCENDANT_GENES (ZER0_INDEX) = 0.0 
for THIS_NEIGHB0R = 1 to NEIGHB0R_C0UNT (ZERO_INDEX) 

if NEIGHB0R_EDGE (ZER0_INDEX, THIS_NEIGHBOR) = PARENT then 

call ZER0_PR0 PORTION ' & 

(NEIGHB0R_INDEX (ZERO_INDEX, THIS_NEIGHB0R) , 0) 
end if 
next THISJNEIGHBOR 
end sub ! ZER0_PR0P0RTI0N 
i 
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17280 

17290 

17300 

17310 

17320 

17330 

17340 

& 

17350 

17360 

17370 

& 

17380 

17390 

17400 

17410 

17420 

& 

17430 

17440 

17450 

17460 

17470 

17480 

17490 

17500 

17510 

& 

17520 

17530 

17540 

17550 

17560 

17570 

& 

& 

& 

17610 

17620 

17630 

17640 

17650 


sub MARK_PR0P0RTI0N (MARKER$, PROPORTION, MARKEDJLNDEX, THIS_NEIGHBOR) 
MARK_PROPORTION recursively seeks out all ancestors and 
marks them with the sender's PROPORTION of shared 
genetic material. This PROPORTION is diluted by one-half 
for each generation 
let DESCENDANT_IDENTIFIER$ (MARKED_INDEX) = MARKER$ 
let DESCENDANT_GENES (MARKED_INDEX) = & 

DESCENDANTJSENES (MARKED_INDEX) + PROPORTION 
for THIS_NEIGHBOR = 1 to NEIGHB0R_C0UNT ( MARKED_INDEX ) 

if NEIGHBOR_EDGE (MARKED_INDEX, THIS_NEIGHB0R) = PARENT then 

call MARK_PR0P0RTI0N (MARKER$, PROPORTION / 2.0, & 

NEIGHB0R_INDEX (MARKEDJLNDEX, THIS_NEIGHB0R) , 0) 
end if 
next THIS_NEIGHB0R 
end sub ! MARK_PR0P0RTI0N 
j 

sub CHECK_C0MM0N_PR0P0RTI0N (C0MM0N_PR0 PORTION, MATCH_IDENTIFIER$, & 
PROPORTION, ALREADY_COUNTED, CHECK_INDEX, THIS_NEIGHBOR) 
CHECR_C0MM0N_PR0P0RTI0N searches all the ancestors of 
CHECK_INDEX to see if any have been marked, and if so 
adds the appropriate amount to C0MM0N_PR0 PORTION 
if DESCENDANT_IDENTIFIER$ (CHECK_INDEX) = MATCH_IDENTIFIER$ then 
Increment C0MM0N_PR0P0RTI0N by the contribution of 
this common ancestor, but discount for the contribution 
of less remote ancestors already counted 
let THIS_C0NTRIBUTI0N = DESCENDANT_GENES (CHECK_INDEX) * PROPORTION 
let C0MM0N_PR0P0RTI0N = C0MM0N_PR0P0RTI0N & 

+ THIS_C0NTRIBUTI0N - ALREADY_C0UNTED 
else 

let THIS_CONTRIBUTION =0.0 
end if 
for THIS_NEIGHB0R = 1 to NEIGHB0R_C0UNT (CHECK_INDEX) 

if NEIGHBOR EDGE (CHECK INDEX, THIS NEIGHBOR) = PARENT then 


call CHECK_C0MM0N_PR0P0RTI0N (COMM0NJPR0P0RTION, 
MATCH_IDENTIFIER$, PROPORTION / 2.0, 
THIS_CONTRIBUTION / 4.0, 

NEIGHBOR_INDEX (CHECK_INDEX, THIS_NEIGHBOR) , 0) 
end if 
next THIS_NEIGHBOR 
j 

end sub ! end of internal sub CHECK_C0MM0N_PR0P0RTI0N 
end sub ! end of external sub COMPUTE COMMON GENES 
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4.0 C 

The identifiers NULL and FILE are capitalized, even though they are supplied by 
the standard run-time library, because identifiers in C are case-sensitive, 
e.g., "null" is not equivalent to "NULL". 

/* Bring in standard routines for run-time support */ 

//include <stdio.h> 

/* Global types and objects */ 

typedef short int BOOLEAN; 

//define TRUE 1 

//define FALSE 

//define EQUALS 

//define NULL_ID "000" 

//define NULL_CHR '\0' 

//define MAX_PERS 300 

//define NAME_LEN 20 

/* every PERSON has a unique 3-digit IDENT */ 
//define ID_LEN 3 

//define BUF_LEN 60 

/* Use "+ 1" when treating type as variable-length - extra character 
used to hold NULL_CHR termination character. */ 
typedef char NAME_TYP [NAMEJLEN + 1]; 
typedef char BUF_TYPE [BUF_LEN + 1]; 
typedef char MSG_TYPE [40 + 1]; 
typedef char IDJTYPE [ID_LEN + 1]; 

typedef int INDXJTYP, COUNTER; 

/* each PERSON'S record in the file identifies at most thre' 
others directly related: father, mother, and spouse */ 

typedef short int GIVEN_ID; 
//define FATHR_ID 
//define M0THR_ID 1 
//define SP0US_ID 2 
//define MAXjGVEN 3 

typedef IDJTYPE REL_ARRY [MAX_GVEN]; 

//define REQ_0K "Request OK" 
//define REQ_ST0P "stop" 

typedef char GNDR_TYP; 
//define MALE 'M' 

//define FEMALE 'F' 
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typed ef unsigned int REL_TYPE; 

/* Values defined as octal powers of two to facilitate comparisons 
of one relation with several possibilities. */ 


//define PARENT 

//define CHILD 

//define SPOUSE 

//define SIBLING 

//define UNCLE 

//define NEPHEW 

//define COUSIN 

//define NULL REL 


0001 
0002 
0004 
0010 
0020 
0040 
0100 
0200 


/* directed edges in the graph are of a given type */ 
typedef REL_TYPE EDG_TYPE; 

/* A node in the graph (= PERSON) has either already been reached, 

is immediately adjacent to those reached, or farther away. */ 

typedef short int REACHJTY; 
//define REACHED 1 
//define NEARBY 2 
//define NOT SEEN 3 


/* each PERSON has a linked list of adjacent nodes, called neighbors */ 
typedef struct NBR_N0DE 
{ INDX_TYP NBR_DEX; 

EDG_TYPE NBR_EDGE ; 

struct NBR_N0DE *NEXT_NBR; 

} 

NBR_REC, *NBR_PTR; 

/* All relationships are captured in the directed graph of which 

each record is a node . */ 
typedef struct 
{ 
/* static information - filled from PEOPLE file: */ 

NAME_TYP NAME ; 

ID_TYPE IDE NT; 

GNDR_TYP GENDER; 

/* IDENTs of immediate relatives - father, mother, spouse */ 

REL_ARRY REL_ID; 

/* head of linked list of adjacent nodes */ 

NBR_PTR NBR_HDR; 
/* data used when traversing graph to resolve user request: */ 

float DISTJSRC ; 

INDXJTYP PATHPRED; 

EDG_TYPE EDG_PRED; 

REACHJTY REACH_ST ; 
/* data used to compute common genetic material */ 

ID_TYPE DSC_ID; 

float DSC GENE; 

} 
PERS REC; 
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/* the PERSON array is the central repository of information 

about inter-relationships. */ 
PERS_REC PERSON [MAX_PERS]; 

INDX_TYP NUM_PERS; 

/* Key persons are the ones in the REL_SHIP path which remain 
after the path is condensed. */ 

typedef short int SIBJTYPE; 

#def ine STEP 1 

#def ine HALF 2 

#def ine FULL 3 


typedef struct 


{ 


RELJTYPE 

INDXJTYP 

COUNTER 

SIBJTYPE 

COUNTER 


} 

KEY REC; 


REL__NEXT; 
PERS_DEX; 
GENJ3AP; 
PROXIMTY; 
CUZ RANK; 


/«**««*««** Main u n e of execution RELATE **********/ 
main ( ) 


{ /* These variables are used when establishing the PERSON array 
from the PEOPLE file. «/ 


FILE 

register INDXJTYP 

IDJTYPE 

GIVEN_ID 

char 


*fopen(), "PEOPLE; 

CURRENT, PREVIOUS; 

PREVJED, CUR_ID; 

RELJ5HIP; 

INP BUF [100]; 


/* These variables are used to accept and resolve requests for 

RELJ5HIP information. */ 
COUNTER SEMIJLOC; 

BUFJTYPE REQJBUF; 

BUF TYPE P1_IDENT, P2__IDENT; 

COUNTER P1_F0UND, P2_F0UND; 

MSG TYPE ERR MSG; 

INDX TYP P1 TNDEX, P2 INDEX; 
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/* *** execution of main sequence begins here *** */ 

PEOPLE = fopen( "PEOPLE. MT", "r"); 

/* This loop reads in the PEOPLE file and constructs the PERSON 
array from it (one PERSON == one record == one array entry). 
As records are read in, links are constructed to represent the 
PARENT -CHILD or SPOUSE REL_SHIP. The array then implements 
a directed graph which is used to satisfy subsequent user 
requests. The file is assumed to be correct - no validation 
is performed on it . */ 
READJPEO: 

for (CURRENT = 0; ; CURRENT-H-) 

{ 

/* copy direct information from file to array */ 
if (FXD_GETC (PERSON [CURRENT] . NAME, PEOPLE, NAME_LEN) 
== EOF) 
break; 

FXD_GETC (PERSON [CURRENT] . IDENT, PEOPLE, ID_LEN); 
FXDJGETC (&(PERS0N [CURRENT] . GENDER), PEOPLE, 1); 
for (REL_SHIP = FATHR_ID; REL_SHIP < MAX_GVEN; REL_SHIP-H-) 

FXD_GETC (PERSON [CURRENT] . REL_ID [REL_SHIP] , PEOPLE, ID_LEN); 
/* flush remainder of record */ 
fgets (INP_BUF, 100, PEOPLE); 

/* Location of adjacent persons as yet undetermined */ 
PERSON [CURRENT] . NBR_HDR = NULL; 
/* Descendants as yet undetermined */ 
strcpy (PERSON [CURRENT] . DSC_ID, NULL_ID); 
/* Compare this PERSON against all previously entered PERSONS 

to search for REL_SHIPs. */ 
strcpy (CUR_ID, PERSON [CURRENT] . IDENT); 
CMP_PREV: 

for (PREVIOUS = 0; PREVIOUS < CURRENT; PREVIOUS-H-) 
{ 

strcpy (PREVJLD, PERSON [PREVIOUS] . IDENT); 
/* Search for father, mother, or spouse relationship in 
either direction between this and PREVIOUS PERSON. 
Assume at most one REL_SHIP exists. */ 
TRY_RELS : 

for (REL_SHIP = FATHRJLD; REL_SHIP < MAX_GVEN; REL_SHIP-H-) 

{ 
if (STREQ (PREV ID, PERSON [CURRENT] . REL ID [REL_SHIP])) 

{ 

LINK_REL (CURRENT, REL_SHIP, PREVIOUS); 
break ; 
} 
else 

if (STREQ (CUR ID, PERSON [PREVIOUS] . REL ID [REL SHIP])) 
{ 

LINKREL (PREVIOUS, REL_SHIP, CURRENT); 
break; 

} 
} /* end TRY_RELS */ 
} /* end CMP_PREV */ 
} /* end READ_PE0 */ 
NUMJPERS = CURRENT; 
f close (PEOPLE); 
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/* PERSON array is now loaded and edges between immediate relatives 
(PARENT-CHILD or SPOUSE -SPOUSE) are established. 

While-loop accepts requests and finds REL_SHIP (if any) 
between pairs of PERSONS. */ 

PROC_REQ: 

while (TRUE) 
{ 

PROMPT (REQJBUF); 
if (STREQ (REQ_BUF, REQ_STOP)) 
break ; 

SEMIJLOC = CHK_RQST (REQJBUF, ERR_MSG); 

/* Syntax check of request completed. Now either display error 
message or search for the two PERSONS. */ 

if (STREQ (ERRJ4SG, REQ_OK)) 

{ /* Request syntactically correct - search for requested PERSONS. */ 
REQ_BUF [SEMI_LOC] = NULL_CHR; 
BUF_PERS (REQ_BUF, 0, P1_IDENT); 
BUF_PERS (REQ_BUF, SEMI_L0C + 1, P2_IDENT); 
SEEK_PER (P1JEDENT, P2_IDENT, & P1_INDEX, & P2_INDEX, 

& P1_F0UND, & P2_F0UND); 
if (Pl_FOUND == 1 && P2_F0UND == 1) 

/* Exactly one match for each PERSON - proceed to 

determine REL_SHIP, if any. */ 
if (P1_INDEX — P2_INDEX) 

printf (" %ls is identical to %8s \n" , 
PERSON [P1JLNDEX] . NAME, 
(PERSON [P1_INDEX] . GENDER == MALE) ? 
"himself." : "herself."); 
else 

FIND_REL (P1_INDEX, P2_INDEX); 
else /* either not found or more than one found */ 
if (P1_F0UND == 0) 

printf (" First person not found.\n"); 
else if (Pl_FOUND > 1) 
{ 
printf (" Duplicate names for first person -"); 
printf (" use numeric identif ier .\n"); 

} 
if (P2JF0UND ==0) 

printf (" Second person not found.\n"); 
else if (P2_FOUND > 1) 

{ 
printf (" Duplicate names for second person -"); 
printf (" use numeric identifier .\n"); 

} 
} /* end processing of syntactically legal request */ 
else 

printf (" Incorrect request format: %ls \n" , ERR_MSG); 
} /* end PR0C_REQ loop */ 
printf (" End of relation-finder. \n"); 

} 

/* End of main line of RELATE */ 
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/* procedures under RELATE »/ 

FXD GETC (RECEIVER, SENDING, GET LEN) 


char 

•RECEIVER; 

FILE 

•SENDING; 

int 

GET LEN; 


{ register int CHAR_CNT; 

for (CHARJJNT =0; 

CHAR_CNT++ < GET_LEN && (»RECEIVER++ = getc (SENDING)) ! = EOF ; ) ; 
if (CHAR_CNT >= GET_LEN) 
{ 

•RECEIVER = NULL_CHR; 
return IE0F; 
} 
else 

return EOF; 
} 

STREQ (STRING1, STRING2) 

/• compare for equality, ignore trailing spaces •/ 

register char »STRING1, «STRING2; 

{ register char "LONGER; 

for ( ; «STRING1 == «STRING2; STRING1++, STRING2++) 
if (»STRING1 == NULL_CHR) 
return TRUE; 
if (»STRING1 == NULL_CHR) 

LONGER = STRING2; 
else 

if («STRING2 == NULL_CHR) 

LONGER = STRING1; 
else 

return FALSE; 
for ( ; »L0NGER++ =='';); 
return («— LONGER == NULL CHR); 
} 
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LINKRE'L (FROM_DEX, REL_SHIP, TO_INDEX) 

/* establishes cross-indexing between immediately related PERSONS. */ 
register INDXJTYP FROMJDEX, TO_INDEX; 

register GIVEN_ID REL_SHIP; 

{ /* execution of LINK_REL */ 
if (REL_SHIP == SPOUS_ID) 

{ 

LINK_ONE (FR0MJ3EX, SPOUSE, TOJENDEX); 
LINK_ONE (TO_INDEX, SPOUSE, FROMJDEX); 

} 
else /* REL_SHIP is father or mother */ 

{ 

LINK_ONE (FROM_DEX, PARENT, TO_INDEX); 
LINK_ONE (TO_INDEX, CHILD, FROMJDEX); 

} 
} 

LINKJDNE (FROM_DEX, THIS_EDG, TO_INDEX) 

/* Establishes the NBR_REC from one PERSON to another */ 

INDXJTYP FROMJDEX, TOJENDEX; 

EDGJTYPE THIS_EDG; 

{ register NBR_PTR NEW_NBR; 

NEW_NBR = (NBR_REC * ) calloc(l, sizeof (NBRJREC)); 
NEW_NBR -> NBRJDEX = TO_INDEX; 
NEW_NBR -> NBR_EDGE = THISJEDG; 

NEW_NBR -> NEXT_NBR = PERSON [FROMJDEX] . NBRJiDR; 
PERSON [FROMJDEX] . NBRJHDR = NEW_NBR; 
} 

PROMPT (REQJBUF) 

/* Issues prompt for user-request, reads in request, 

blank-fills buffer, and skips to next line of input. */ 

BUF TYPE REQ BUF; 


print f (" \n"); 

printf (" \n"); 

printf (" Enter two per son- identifiers (name or number) ,\n"); 
printf (" separated by semicolon. Enter \"stop\" to stop.\n"); 
fgets (REQ_BUF, BUFJ.EN, stdin); 
for ( ; *REQJBUF-H- != '\n' ; ) ; 
*— REQ BUF = '\0'; 
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CHKJtQST (REQJ5UF, REQ_STAT) 

/* Performs syntactic check on request in buffer. */ 


BUF TYPE 
MSG_TYPE 


REQ BUF; 
REQ_STAT ; 


{ COUNTER 
register 

COUNTER 

SEMI LOC 
SEMI CNT 
BUF_DEX; 

- 1, 
= 0; 

BOOLEAN 


PI EXIST - 
P2 EXIST - 

FALSE, 
FALSE ; 


strcpy (REQ_STAT, REQ_OK); 

for (BUFJDEX - 0; BUF_DEX < BUF_LEN && REQJBUF [BUF DEX]; BUF_DEX-H-) 

{ 

if (REqjBUF [BUF_DEX] != ' ') 
if (REQ_BUF [BUF_DEX] — ';') 

{ 
SEMI_LOC = BUF_DEX; 
SEMI_CNT - SEMI_CNT + 1; 

} 
else /* Check for non-blanks before/after semicolon. */ 
if (SEMI_CNT < 1) 

P1_EXEST - TRUE; 
else 

P2_EXIST = TRUE; 
} 

/* set REQ_STAT, based on results of scan of REQ_BUF. */ 
if (SEMI_CNT != 1) 

strcpy (REQ_STAT, "must be exactly one semicolon."); 
else if ( ! P1_EXIST) 

strcpy (REQJ5TAT, "null field preceding semicolon."); 
else if ( ! P2_EXIST) 

strcpy (REQ_STAT, "null field following semicolon."); 
return SEMI_L0C; 
} 

BUFJ?ERS (REQJBUF, BUF_DEX, PERSJLD) 

/* fills in the PERSJLD from the designated portion 
of the REQJBUF, deleting leading blanks. */ 

BUFJTYPE REQ_BUF; 

register COUNTER BUFJJEX; 
NAMEJTYP PERS_ID; 

{ 

for ( ; REQJBUF [BUFJDEX++-] — ' '; ) ; 
strcpy (PERS ID, &REQ BUF [—BUF DEX] ); 

} ~ 
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SEEK_PER (P1_IDENT, P2_IDENT, P1_INDEX, P2_INDEX, 

P1_FOUND, P2__FOUND) 
/« SEEK__PER scans through the PERSON array, 

looking for the two requested PERSONS. Match may be by NAME 
or unique IDENT-number. */ 


BUFJTYPE 
INDX_TYP 
COUNTER 


P1_IDENT, P2_IDENT; 
*P1_INDEX, «P2_INDEX; 
*P1 FOUND, »P2 FOUND; 


{ register INDX TYP CURRENT; 


»P1_INDEX = 0; 
*P2_INDEX = 0; 
•P1JF0UND = 0; 
»P2_F0UND = 0; 
SCANNER: 

for (CURRENT = 


0; CURRENT < NUM PERS; CURRENT++) 


{ 


/* allow identification by name or number. »/ 
if (STREQ (P1_IDENT, PERSON [CURRENT] . IDENT) 
STREQ (P1 IDENT, PERSON [CURRENT] . NAME)) 


{ 


(«P1_FOUND)++; 
»P1_INDEX = CURRENT; 
} 
if (STREQ (P2_IDENT, PERSON [CURRENT] 
STREQ (P2_IDENT, PERSON [CURRENT] 
{ 
(»P2_F0UND)++; 
•P2JENDEX = CURRENT; 
} 
/• end SCAN_PER loop «/ 
/» end of SEEK PER »/ 


IDENT) 
NAME)) 
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FIND_REL (TARG_DEX, SRCfijDEX) 

/* Finds shortest path (if any) between two PERSONS and 
determines their REL_SHIP based on immediate relations 
traversed in path. PERSON array simulates a directed graph, 
and algorithm finds shortest path, based on following 
weights: PARENT-CHILD edge - 1.0 

SPOUSE-SPOUSE edge = 1.8 */ 

INDXJTYP TARG_DEX, SRCE_DEX; 

{ register INDXJTYP PERS_DEX; 

INDXJTYP THIS_N0D, BESTJDEX, LSTJJRBY, 

NRBY_ND [MAX_PERS]; 
register NBR_PTR THIS_NBR; 

float MINJDIST; 

typedef short int SRCHJTYP; 

# define SEARCHNG 1 

//define SUCCESS 2 

#define FAILED 3 

SRCHJTYP SRCHJST; 

/* begin execution of FIND_REL */ 

/* initialize PERSON-array for processing - 

mark all nodes as not seen */ 
for (PERSJDEX - 0; PERS_DEX < NUM_PERS; PERS_DEX-H-) 

PERSON [PERSJ)EX] . REACH_ST - NOT_SEEN; 
THIS_N0D - SRCEJDEX; 
/* mark source node as REACHED */ 
PERSON [THIS_N0D] . REACH_ST = REACHED; 
PERSON [THIS_NOD] . DIST_SRC = 0.0; 
/* no NEARBY nodes exist yet */ 
LST_NRBY - -1; 
SRCH ST - (THIS NOD — TARG DEX) ? SUCCESS : SEARCHNG; 
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/* Loop keeps processing closest-to-source, unREACHED node 
until target REACHED, or no more connected nodes. */ 
SEEKTARG: 

while (SRCH_ST — SEARCHNG) 

{ /* Process all nodes adjacent to THIS_NOD */ 
for (THIS_NBR - PERSON [THIS_NOD] . NBR_HDR; 
THIS_NBR != NULL; 
THISJJBR - THIS_NBR -> NEXT_NBR) 
PROC_ADJ (THIS_NOD, THIS_NBR -> NBR_DEX, THIS_NBR -> NBR_EDGE, 
NRBY_ND, &LST_NRBY); 

/* All nodes adjacent to THIS_NOD are set. Now search for 

shortest-distance unREACHED (but NEARBY) node to process next. */ 

if (LST_NRBY — -1) 
SRCH_ST = FAILED; 

else /* determine next node to process */ 

{ 

MIN_DIST = 1.0E+18; 

for (PERS_DEX = 0; PERS_DEX <= LST_NRBY; PERS_DEX++) 
if (PERSON [NRBY ND [PERS DEX]] . DIST SRC < MIN DIST) 
{ ~ " 

BEST_DEX = PERS_DEX; 
MIN DIST = PERSON [NRBY ND [PERS DEX]] . DIST SRC; 

} ~ ~ 

/* establish new THIS_N0D */ 
THIS_N0D = NRBY_ND [BEST_DEX]; 

/* change THIS_N0D from being NEARBY to REACHED */ 
PERSON [THIS_N0D] . REACHJ3T = REACHED; 
/* remove THIS_N0D from NEARBY list */ 
NRBY_ND [BEST_DEX] = NRBY_ND [LST_NRBY— ]; 
if (THIS_N0D == TARGJOEX) 
SRCH ST = SUCCESS; 

} 
} /* end SEEKTARG loop */ 

/* Shortest path between PERSONS now established. Next task is 

to translate path to English description of REL_SHIP. */ 
if (SRCH_ST = FAILED) 

printf (" %ls is not related to %ls\n" , 

PERSON [TARG_DEX] . NAME, PERSON [SRCEJDEX] . NAME); 
else /* success - parse path to find and display REL_SHIP */ 
{ 

RESOLVE (SRCE_DEX, TARGJDEX); 
CMPT GNS (SRCE DEX, TARG DEX); 
} 
} /* end FIND REL */ 
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/* procedures under FIND_REL */ 

PROC_ADJ (BASENODE, NXT_N0DE, N_B_EDGE, NRBY_ND, LST_NRBY) 
/* NXT_NODE is adjacent to last-REACHED node (== BASENODE). 
If NXT_NODE already REACHED, do nothing. 
If previously seen, check whether path thru BASENODE is 
shorter than current path to NXTJJODE, and if so re-link 
next to base. 
If not previously seen, link next to base node. */ 

register INDX_TYP NXT_NODE; 

INDX_TYP BASENODE, NRBY_ND[], *LST_NRBY; 

EDGJCYPE N_B_EDGE; 

{ float WGHT_EDG, DIST_BAS; 

/* begin execution of PROC_ADJ */ 

if (PERSON [NXT_NODE] . REACHJST != REACHED) 

{ 

WGHT_EDG = (N_B_EDGE — SPOUSE) ? 1.8 : 1.0; 
DIST_BAS = WGHT_EDG ■ + PERSON [BASENODE] . DIST_SRC; 
if (PERSON [NXTJJODE] . REACHJST — N0T_SEEN) 

{ 

PERSON [NXTJJODE] . REACH_ST = NEARBY; 
NRBY_ND [-H- *LST_NRBY] - NXTJJODE; 
/* link next to base by re-setting its predecessor index to 

point to base, note type of edge, and re-set distance 

as it is through base node. */ 
PERSON [NXTJTODE] . DISTJSRC - DIST_BAS; 
PERSON [NXT _NODE ] . PATHPRED - BASENODE ; 
PERSON [NXTJJODE] . EDG_PRED = N_B_EDGE; 

} 
else /* REACHJST = NEARBY */ 

if (DISTJBAS < PERSON [NXTJJODE] . DISTJSRC) 

{ /* link next to base by re-setting its predecessor index to 
point to base, note type of edge, and re-set distance 
as it is through base node. */ 
PERSON [NXTJJODE] . DIST_SRC = DIST_BAS; 
PERSON [NXTJJODE] . PATHPRED = BASENODE; 
PERSON [NXTJJODE] . EDG_PRED = N_B_EDGE; 
} 
} 
} /* end PROC ADJ */ 
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RESOLVE (SRCEJDEX, TARGJ)EX) 

/* RESOLVE condenses the shortest path to a 

series of REL_SHIPs for which there are English 
descriptions . */ 

INDXJTYP SRCE_DEX, TARG_DEX; 

{ /* these variables are used to generate KEY_PERSs */ 
COUNTER GEN_CNT; 

/* these variables are used to condense the path */ 

KEY_REC KEY_PERS [MAX_PERS]; 

REL_TYPE KEY_REL, LKEY_REL, PRIM_REL, NXT_PRIM; 

register INDXJTYP KEYJDEX; 

INDXJTYP LKEYJ)EX, PRIMJDEX, THIS_NOD; 

BOOLEAN SEEKMORE ; 


/* begin execution of RESOLVE */ 

printf (" Shortest path between identified persons: \n"); 
/* Display path and initialize KEY_PERS array from path elements. */ 
TRAVERSE : 

for (THIS_NOD = TARGJDEX, KEYJ)EX = 0; THISJJOD != SRCEJ)EX; 
THIS_N0D - PERSON [THISJJOD] . PATHPRED, KEYJ)EX-H-) 

{ 

printf (" %ls is ", PERSON [THISJJOD] . NAME); 
KEYJPERS [KEYJDEX] . PERSJ)EX = THIS_N0D; 
KEY_PERS [KEYJDEX] . PROXIMTY = FULL; 

REY_PERS [KEYJDEX] . RELJJEXT = PERSON [THISJJOD] . EDGJPRED; 
switch (PERSON [THISJJOD] . EDG_PRED) 

{ 
case PARENT: printf ("parent of\n"); 

KEY_PERS [KEYJ)EX] . GENjGAP « 1; 
break; 
case CHILD : printf ("child of\n"); 

KEY_PERS [KEYJDEX] . GENJ3AP = 1; 
break ; 
case SPOUSE: printf ("spouse of\n"); 

KEY_PERS [KEYJDEX] . GENjGAP = 0; 
break; 
} /* end switch */ 
} /* end TRAVERSE loop */ 
printf (" %ls\n", PERSON [THISJJOD] . NAME); 
KEYJPERS [KEYJDEX] . PERSJDEX = THISJJOD; 

KEY_PERS [KEYJ)EX] . RELJJEXT = NULL_REL; 

KEY PERS [KEY DEX + 1] . REL NEXT = NULL REL; 
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/* Resolve CHILD-PARENT and CHILD -SPOUSE -PARENT relations 
to SIBLING relations. */ 
FIND_SIB: 

for (KEY_DEX = 0; KEY_PERS [KEY_DEX] . REL_NEXT != NULL_REL; KEYJDEX++) 

{ 
if (KEYJPERS [KEYJDEX] . REL_NEXT — CHILD) 

{ 

LKEY_REL - KEY_PERS [KEY_DEX + 1] . REL_NEXT; 
if (LKEY_REL == PARENT) 

{ /* found either full or half SIBLINGS */ 
BOOLEAN F ULL_S IB ( ) ; 

KEY_PERS [KEYJDEX] . PROXIMTY = 

FULL_SIB (KEY_PERS [KEY_DEX] . PERS_DEX, 

KEY_PERS [KEYJDEX + 2] . FERSJDEX) 
? FULL : HALF; 

KEY_PERS [KEY_DEX] . GEN_GAP = 0; 

KEY_PERS [KEYJDEX] . REL_NEXT = SIBLING; 

CONDENSE (KEYJDEX, 1, KEYJ»ERS); 

} 
else 

if (LKEYJtEL == SPOUSE 

&& KEYJ>ERS [KEYJDEX + 2] . REL_NEXT — PARENT) 
{ /* found step-SIBLINGs */ 
KEYJ>ERS [KEYJDEX] . GENJ3AP = 0; 
KEYJ»ERS [KEYJDEX] . PROXIMTY = STEP; 
KEYJ>ERS [KEYJDEX] . REL_NEXT = SIBLING; 
CONDENSE (KEYJDEX, 2, KEY_PERS); 

} 
} /* end if RELJTEXT == CHILD */ 
} /* end FIND_SIB loop */ 

/* Resolve CHILD-CHILD-... and PARENT -PARENT -.. . relations to 
direct descendant or ancestor relations. */ 
FIND_ANC: 

for (KEYJDEX = 0; KEYJ>ERS [KEYJDEX] . REL_NEXT != NULL REL; KEY DEX++) 

{ 
if (KEYJPERS [KEYJDEX] . REL_NEXT == CHILD | | 
KEY_PERS [KEYJDEX] . REL_NEXT == PARENT) 

{ 
for (LKEYJDEX = KEYJDEX + 1; 

KEYJPERS [LKEYJDEX] . REL_NEXT == KEYJ>ERS [KEYJDEX] . REL_NEXT; 

LKEYJDEX4+) ; 
GENJ:NT = LKEYJDEX - KEYJDEX; 
if (GENJCNT > 1) /* compress generations */ 

{ 
KEYJ>ERS [KEYJDEX] . GENJ3AP = GENJJNT; 
CONDENSE (KEYJDEX, GEN_CNT - 1, KEY_PERS); 

} 
} /* end if REL_NEXT — CHILD or PARENT */ 
} /* end FIND ANC loop */ 
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■ /* Resolve CHILD-SIBLING-PARENT to COUSIN, 

CHILD-SIBLING to NEPHEW, 

SIBLING-PARENT to UNCLE. */ 
FIND_CUZ: 

for (KEY DEX = 0; KEY PERS [KEY DEX] . REL NEXT != NULL REL; KEY DEX-H-) 

{ ----- 

LKEY_REL = KEYJPERS [KEY_DEX + 1] . REL_NEXT; 

if (KEY_PERS [KEY_DEX] . REL_NEXT == CHILD && LKEY_REL == SIBLING) 
{ /* COUSIN or NEPHEW */ 
if (KEYJPERS [KEY_DEX + 2] . REL_NEXT == PARENT) 
{ /* found COUSIN */ 
COUNTER GAP1, GAP2; 


GAP1 = KEY_PERS [KEY_DEX] 
GAP2 = KEY_PERS [KEYJDEX + 2] 
KEY_PERS [KEYJDEX] 
KEY_PERS [KEYJDEX] 

= (GAP1 < GAP2) 
KEY_PERS [KEYJDEX] . 
KEY_PERS [KEYJDEX] . 
CONDENSE (KEYJDEX, 2, 

} 
else 


GENjGAP; 
GENJ3AP; 
PROXIMTY = KEY_PERS [KEYJDEX + 1] . PROXIMTY; 
GENJ3AP 
? (GAP2 - GAP1) : (GAP1 - GAP2); 
CUZ_RANK = (GAP1 < GAP2) ? GAPl : GAP2; 
REL_NEXT = COUSIN; 
KEY PERS); 


/* found NEPHEW */ 


} 
else 

if 


{ 

KEY_PERS [KEYJDEX] 
KEY_PERS [KEYJDEX] 
CONDENSE (KEYJDEX, 

} 

/* 


. PROXIMTY - KEY_PERS 
. RELJJEXT = NEPHEW; 
1, KEY PERS); 


[KEY DEX + 1] . PROXIMTY; 


end COUSIN or NEPHEW */ 

REL NEXT == SIBLING && LKEY REL == PARENT) 


(KEY_PERS [KEYJDEX] 
{ /* found UNCLE ' 
KEY_PERS [KEYJDEX] 
KEY_PERS [KEYJDEX] 
CONDENSE (KEY DEX, 
} 


7 

. GENJ3AP = KEY_PERS [KEYJDEX + 1] 
. REL_NEXT = UNCLE; 
1, KEY PERS); 


GEN GAP; 


} /* end FIND CUZ loop */ 
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/* Loop below will pick out valid adjacent strings of elements 
to be displayed. KEY_DEX points to first element, 
LKEY_DEX to last element, and PRIM_DEX to the 
element which determines the primary English word to be used. 
Associativity of adjacent elements in condensed table 
is based on English usage. */ 

printf (" Condensed path:\n"); 
CONSLIDT : 

for (KEYJDEX = 0; KEY_PERS [KEY_DEX] . REL_NEXT != NULL_REL; 
KEY DEX - LKEY DEX + 1) 
{ 

KEY_REL = KEY_PERS [KEY_DEX] . REL_NEXT; 
LKEY_DEX = KEY_DEX; 
PRIM_DEX = KEY_DEX; 

if (KEY_PERS [KEYJDEX + 1] . REL_NEXT != NULL_REL) 
{ /* seek multi-element combination */ 
SEEKMORE = TRUE; 
if (KEYJREL == SPOUSE) 

{ 

PRIM_DEX = ++LKEY_DEX; 

/* Nothing can follow SPOUSE-SIBLING or SPOUSE-COUSIN */ 
SEEKMORE = ! (KEY PERS [LKEYJDEX] . REL NEXT & (SIBLING I COUSIN)); 
} 
/* PRIM_DEX is now correctly set. Next if-statement 
determines if a following SPOUSE relation should be 
appended to this combination or left for the next 
combination . */ 
if (SEEKMORE && KEY_PERS [PRIM_DEX + 1] . REL_NEXT == SPOUSE) 
{ /* Only a SPOUSE can follow a Primary; 

check primary preceding and following SPOUSE. */ 
PRIM_REL = KEY_PERS [PRIM_DEX] . REL_NEXT; 

NXT_PRIM - KEYJPERS [PRIM_DEX + 2] . REL_NEXT; 
if ((NXT_PRIM & (NEPHEW I COUSIN | NULL_REL)) 
I | (PRIM_REL — NEPHEW) 

j| ((PRIM_REL & (SIBLING | PARENT)) && NXTJPRIM != UNCLE )) 
/* append following SPOUSE with this combination. */ 
LKEY DEX++; 

} 
} /* end multi-element combination */ 
SH0W_REL (KEY_DEX, LKEY_DEX, PRIM_DEX, KEY_PERS); 
} /* end CONSLIDT loop */ 
printf (" %ls\n", PERSON [KEY_PERS [KEY_DEX] . PERS_DEX] . NAME); 
} /* end of RESOLVE */ 
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BOOLEAN FULL_SIB (INDEXl, INDEX2) 

/* Determines whether two PERSONS are full siblings, i.e., 

have the same two parents. */ 
register INDX TYP INDEXl, INDEX2; 


{ 


} 


return 

! STREQ (PERSON [INDEXl] 
! STREQ (PERSON [INDEXl] 
STREQ (PERSON [INDEXl] . 

PERSON [INDEX2] . 
STREQ (PERSON [INDEXl] . 

PERSON [INDEX2] . 


. REL_ID [FATHR_ID], NULL_ID) && 

. REL_ID [MOTHR__ID], NULL_ID) && 

REL_ID [FATHR_ID], 

REL_ID [FATHR_ID]) && 

REL_ID [MOTHR_ID], 

REL_ID [MOTHR_ID]); 


CONDENSE (ATJNDEX, GAP_SIZE, KEY_PERS) 

/* CONDENSE condenses superfluous entries from the 
KEY PERS array, starting at AT INDEX. */ 


register INDXJTYP 

COUNTER 

KEY_REC 

{ register INDXJTYP 

do 

{ 


AT_INDEX; 
GAP_SIZE; 
KEY_PERS []; 

SEND DEX; 


} 


AT_INDEX+f; 

SEND_DEX = AT_INDEX + GAP_SIZE; 

KEY_PERS [AT_INDEX] - KEY_PERS [SEND_DEX]; 

} 
while (KEY_PERS [SEND_DEX] . REL_NEXT != NULL_REL); 
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/* procedures under RESOLVE */ 

SHOW_REL (FRST_DEX, IAST_DEX, PRIMJDEX, KEY_PERS) 

/* SHOWJREL takes 1, 2, or 3 adjacent elements in the 

condensed table and generates the English description of 
the relation between the first and last + 1 elements. */ 

INDXJTYP FRSTJDEX, LASTJDEX, PRIM_DEX; 

KEYJREC KEY_PERS []; 

{ BOOLEAN INLAW; 

SIBJTYPE THIS_PRX; 

GNDR_TYP THISJ3ND; 

short int SUFFIX; 

register REL_TYPE FRST_REL, LAST_REL, PRIM_REL; 

COUNTER THISJGAP, THIS_CUZ; 

FRST_REL = KEY_PERS [FRSTJ)EX] . REL_NEXT; 
LAST_REL - KEY_PERS [LAST_DEX] . REL_NEXT; 
PRIM_REL = KEYJPERS [PRIMJDEX] . REL_NEXT; 

/* set THIS_PRX */ 

if ((PRIM_REL == PARENT && FRST_REL — SPOUSE) || 
(PRIM_REL — CHILD && LAST_REL -- SPOUSE)) 
THIS_PRX = STEP; 
else 

if (PRIM_REL & (SIBLING j UNCLE | NEPHEW I COUSIN)) 

THIS_PRX = KEY_PERS [PRIM_DEX] . PROXIMTY; 
else 

THIS_PRX = FULL; 

/* set THISJSAP */ 

if (PRIM_REL & (PARENT | CHILD | UNCLE | NEPHEW I COUSIN)) 

THISJSAP = KEY_PERS [PRIM_DEX] . GENjGAP; 
else 

THISJSAP = 0; 

/* set INLAW */ 

INLAW = FALSE; 

if (FRST_REL — SPOUSE && (PRIM_REL & (SIBLING | CHILD | NEPHEW I COUSIN))) 

INLAW = TRUE; 
else 

if (LASTJIEL = SPOUSE && 

(PRIM_REL & (SIBLING | PARENT | UNCLE | COUSIN))) 
INLAW ■ TRUE; 

/* set THISJ3UZ */ 

if (PRIMJREL — COUSIN) 

THISJSUZ - KEY_PERS [PRIMJ)EX] . CUZ_RANK; 
else 

THIS CUZ = 0; 
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/* parameters are set - now generate display. */ 

printf (" %ls is ", PERSON [KEY PERS [FRST_DEX] . PERSJ3EX] 
if (PRIM_REL & (PARENT | CHILD T UNCLE | NEPHEW) ) 
{ /* display generation-qualifier */ 
if (THIS GAP >= 3) 


NAME); 


{ 


} 


printf ("great"); 
if (THIS_GAP > 3) 
printf ("*%ld" 
printf ("-"); 


THIS GAP ~ 2); 


if (THISJ3AP >= 2) 
printf ("grand-"); 
} 
else 

if (PRIM_REL == COUSIN && THISjCUZ > 1) 


{ 


printf ("%ld", THISJCUZ); 
SUFFIX = THIS_CUZ % 10; 
switch (SUFFIX) 

{ 


case 1 
case 2 
case 3 


printf ("st ") 
printf ("nd ") 
printf ("rd ") 


} 


} 


default: printf ("th ") 


break ; 
break ; 
break ; 
break; 


if (THIS_PRX == STEP) 
printf ("step-"); 

else 

if (THIS_PRX == HALF) 
printf ("half-"); 
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THISjGND = PERSON [KEY_PERS [FRST_DEX] 
switch (PRIM REL) 


PERS DEX] . GENDER; 


{ 


case PARENT 


case CHILD 


case SPOUSE 


MALE) printf 
printf 

MALE) printf 
printf 


if (-THISJSND 
else 
break; 

if (THIS_GND 
else 
break; 

if (THIS_GND == MALE) printf 
else printf 

break; 
case SIBLING: if (THIS_GND = MALE) printf 
else printf 

break; 

if (THIS_GND == MALE) printf 
else printf 

break; 

if (THISJ3ND = MALE) printf 
else printf 

break; 

printf ("cousin"); 
break; 

printf ("null"); 
break ; 


case UNCLE 

case NEPHEW 

case COUSIN 
default 


} 


if (INLAW) 

printf ("-in-law"); 

if (PRIM_REL — COUSIN && THISjGAP > 0) 
if (THIS_GAP > 1) 

printf (" %ld times removed", THISJ3AP); 
else 

printf (" once removed"); 

printf (" of\n"); 
} /* end of SHOW REL */ 


"father"); 
"mother"); 

"son"); 
"daughter"); 

"husband"); 
"wife"); 

"brother") ; 
"sister"); 

"uncle") ; 
"aunt"); 

"nephew" ) ; 
"niece"); 


Page 72 


/* procedures under FIND_REL */ 

CMPTjGNS (INDEX1, INDEX2) 

/* CMPT_GNS assumes that each ancestor contributes 

half of the genetic material to a PERSON. It finds common 
ancestors between two PERSONS and computes the expected 
value of the PROPORTN of common material. */ 

register INDX_TYP INDEX1, INDEX2; 

{ float COM_PROP; 

/* First zero out all ancestors to allow adding. This is necessary 

because there might be two paths to an ancestor. */ 
ZERO_PRO (INDEX1); 

/* now mark with shared PROPORTN */ 
MARK_PRO (PERSON [INDEX1] . IDENT, 1.0, INDEX1); 
C0M_PR0P =0.0; 

CHK_C0M ( & C0M_PR0P, PERSON [INDEX1] . IDENT, 1.0, 0.0, INDEX2); 
printf (" Proportion of common genetic material = %1.5e \n", 
COM_PR0P); 
} /* end of CMPTJGNS */ 

ZER0_PR0 (ZER0_DEX) 

/* ZER0_PR0 recursively seeks out all ancestors and 
zeros them out . */ 

register INDX_TYP ZER0_DEX; 

{ register NBR_PTR THIS_NBR; 

PERSON [ZER0_DEX] . DSC_GENE = 0.0; 
for (THISJJBR = PERSON [ZER0JDEX] . NBR_HDR; 
THIS_NBR != NULL; 
THIS NBR = THIS NBR -> NEXT NBR) 
{ 
if (THIS_NBR -> NBRJEDGE == PARENT) 
ZERO PRO (THIS NBR -> NBR DEX); 
} 
} /* end of ZERO PRO */ 
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MARK_PRO (MARKER, PROPORTN, MARK_DEX) 

/* MARK_PRO recursively seeks out all ancestors and 
marks them with the sender's PROPORTN of shared 
genetic material. This PROPORTN is diluted by one-half 
for each generation. */ 

IDJTYPE MARKER; 

float PROPORTN; 

INDX_TYP MARK_DEX; 

{ register NBR_PTR THIS_NBR; 

strcpy (PERSON [MARK_DEX] . DSC_ID, MARKER); 
PERSON [MARKJffiX] . DSCjGENE -h= PROPORTN; 
for (THIS_NBR - PERSON [MARKJDEX] . NBR_HDR; 
THIS_NBR != NULL; 
THIS NBR = THIS_NBR -> NEXTJJBR) 
{ 
if (THIS_NBR -> NBR_EDGE == PARENT) 

MARK PRO (MARKER, PROPORTN / 2.0, THIS_NBR -> NBRJDEX); 

} 
} /* end of MARK_PR0 */ 

CHKJCOM (C0M_PTR, MATCH_ID, PROPORTN, COUNTED, CHK_DEX) 
/* CHK_C0M searches all the ancestors of 

CHK_DEX to see if any have been marked, and if so 
adds the appropriate amount to *C0M_PTR. */ 

float *C0M_PTR, PROPORTN, COUNTED; 

IDJTYPE MATCH_ID; 

INDX_TYP CHK_DEX; 

{ register NBR_PTR THIS_NBR; 
register float CONTRIB; 

if (STREQ (PERSON [CHK_DEX] . DSC_ID, MATCH_ID)) 
{ /* Increment *C0M_PTR by the contribution of 

this common ancestor, but discount for the contribution 
of less remote ancestors already counted. */ 
CONTRIB = PERSON [CHK_DEX] . DSCjGENE * PROPORTN; 
*C0M PTR 4= CONTRIB - COUNTED; 

} 
else 

CONTRIB =0.0; 
for (THIS_NBR = PERSON [CHK_DEX] . NBR_HDR; 
THIS_NBR != NULL; 
THIS_NBR = THIS_NBR -> NEXTJJBR) 

{ 
if (THIS_NBR -> NBR_EDGE == PARENT) 

CHK_C0M (C0M_PTR, MATCH_ID, PROPORTN / 2.0, 

CONTRIB / 4.0, THIS_NBR -> NBRJDEX); 

} 
} /* end of CHK COM */ 
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5.0 COBOL 


In keeping with the general convention of the examples, language- supplied 
keywords and identifiers are written in lower case in the program. To conform 
strictly to the COBOL-74 standard, however, programs must use only upper-case 
letters. 


* 


Compilation unit number 1 


identification division, 
program-id. RELATE. 

environment division. 

configuration section, 
source- computer. VAX-11. 
object-computer. VAX-11. 

input-output section, 
file-control . 

select PEOPLE assign to "PEOPLE.DAT", 

file status is PEOPLE -STATUS. 

data division. 

file section, 
fd PEOPLE 

label records are standard. 
01 PEOPLE -RECORD. 

05 NAME pic X(20). 

05 IDENTIFIER pic 999. 

*** "M" for MALE and "F" for FEMALE 

05 GENDER pic X. 

05 IMMEDIATE-RELATIONS. 

10 RELATIVE -IDENTIFIER occurs 3 times pic 999. 

working- st or age section. 

77 ARG-PERS0N1-INDEX pic 999. 

77 ARG-PERS0N2-INDEX pic 999. 

01 PEOPLE -STATUS. 

05 STATUS -1 pic X. 

88 END-0F -PEOPLE -FILE value "1". 

05 STATUS -2 pic X. 

* Define global objects 

01 TRUTH-VALUES. 

05 IS-TRUE pic X value "T" . 

05 IS-FALSE pic X value "F" . 

01 SPECIAL-IDENT-VALUE. 

05 NULL-IDENT pic 999 value 000. 
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* each PERSON'S record in the file identifies at most three 

* others directly related: father, mother, and spouse 
01 GIVEN-IDENTIFIERS. 

05 FATHER-IDENT pic 9 value 1. 
05 MOTHER- IDENT pic 9 value 2. 
05 SPOUSE-IDENT pic 9 value 3. 


01 GENDER-TYPE. 





05 

MALE 

pic 

X 

value 

"M" 

05 

FEMALE 

pic 

X 

value 

" F " 

01 RELATION-TYPE . 





05 

PARENT 

pic 

9 

value 

1. 

05 

CHILD 

pic 

9 

value 

2. 

05 

SPOUSE 

pic 

9 

value 

3. 

05 

SIBLING 

pic 

9 

value 

4. 

05 

UNCLE 

pic 

9 

value 

5. 

05 

NEPHEW 

pic 

9 

value 

6. 

05 

COUSIN 

pic 

9 

value 

7. 

05 

NULL -RELATION 

pic 

9 

value 

8. 


* A node in the graph (= PERSON) has either already been reached, 

* is immediately adjacent to those reached, or farther away. 
01 REACHED-TYPE. 

05 REACHED pic 9 value 1. 

05 NEARBY pic 9 value 2. 

05 NOT-SEEN pic 9 value 3. 
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* the PERSON array is the central repository of information 

* about inter-relationships . 

* All relationships are captured in the directed graph of which 

* each record is a node. 
01 PERSON-TABLE. 

05 NUMBER-OF -PERSONS usage index. 
05 PERSON occurs 300 times 

indexed by CURRENT, PREVIOUS, 

FR0M-INDEX, T0-INDEX, 
PERS0N1-INDEX, PERS0N2-INDEX. 
*** static information - filled from PEOPLE file: 
10 NAME pic X(20). 

10 IDENTIFIER pic 999. 

10 GENDER pic X. 

IDENTIFIERS of immediate relatives - father, mother, spouse 
10 IMMEDIATE-RELATIONS. 

15 RELATIVE -IDENTIFIER occurs 3 times indexed by RELATIONSHIP 

pic 999. 
pointers to immediate neighbors in graph 
10 NEIGHBOR-COUNT pic 99. 

10 NEIGHBOR-RECORD occurs 20 times indexed by NEXT -NEIGHBOR. 
15 NEIGHBOR-INDEX usage index. 
15 NEIGHBOR-EDGE pic 9. 

data used when traversing graph to resolve user request : 
10 DISTANCE-FROM-SOURCE pic 99999V9. 
10 PATH-PREDECESSOR usage index. 

10 EDGE-TO-PREDECESSOR pic 9. 
10 REACHED-STATUS pic 9. 

data used to compute common genetic material 
10 DESCENDANT-IDENTIFIER pic 999. 
10 DESCENDANT-GENES pic 9V99999999. 


*** 


*** 


*** 


*** 


* These variables are used to 

* RELATIONSHIP information. 
01 RELATIONSHIPHWORK-ITEMS. 

05 REQUEST-BUFFER 

88 REQUEST-TO-STOP 
05 PERS0N1-IDENT 
05 PERS0N2-IDENT 
05 PERS0N1-F0UND 
05 PERS0N2-F0UND 
05 ERROR-MESSAGE 
05 REQUEST-OK 


accept and resolve requests for 


pic X(60). 
value "stop' 
pic X(20). 
pic X(20). 
pic 999. 
pic 999. 
pic X(40). 
pic X(40) 


value "Request OK' 


01 AUXILIARY-VARIABLES. 

05 RELATION-LOOP-DONE pic X. 

88 RELATION-LOOP-IS -DONE value "T". 

05 TEMP-INDEX usage index 

05 THIS -EDGE pic 9. 

05 LEADING-SPACES pic 99. 

05 SEMICOLON-COUNT pic 99. 

05 CURRENT-IDENT pic 999. 

05 PREVIOUS-IDENT pic 999. 

05 TEMP-IDENT picX(20). 
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procedure division. 
MAIN-LINE. 

open input PEOPLE. 

read PEOPLE at end perform NULL. 

* This loop reads in the PEOPLE file and constructs the PERSON 

* array from it (one PERSON = one record = one array entry). 

* As records are read in, links are constructed to represent the 

* PARENT-CHILD or SPOUSE RELATIONSHIP. The array then implements 

* a directed graph which is used to satisfy subsequent user 

* requests. The file is assumed to be correct - no validation 

* is performed on it. 

perform READ-IN-PEOPLE thru READ-IN-PEOPLE-EXIT 

varying CURRENT from 1 by 1 until END-OF-PEOPLE-FILE. 
set CURRENT down by 1. 
set NUMBER-OF-PERSONS to CURRENT, 
close PEOPLE. 

* PERSON array is now loaded and edges between immediate relatives 

* (PARENT-CHILD or SPOUSE -SPOUSE) are established. 

perform PROMPT -AND -RE AD. 

* While-loop accepts requests and finds RELATIONSHIP (if any) 

* between pairs of PERSONS. 

perform READ-AND-PROCESS-REQUEST thru READ-AND-PROCESS-REQUEST-EXIT 

until REQUEST-TO-STOP, 
display " End of relation-finder.", 
stop run. 

READ-IN-PEOPLE. 
*** copy direct information from file to array 

move corresponding PEOPLE -RECORD to PERSON (CURRENT), 
move IMMEDIATE-RELATIONS of PEOPLE-RECORD 
to IMMEDIATE -RELATIONS of PERSON (CURRENT). 
*** Location of adjacent persons as yet undetermined 
move zero to NEIGHBOR-COUNT of PERSON (CURRENT). 
*** Descendants as yet undetermined 

move NULL-IDENT to DESCENDANT-IDENTIFIER of PERSON (CURRENT), 
move IDENTIFIER of PERSON (CURRENT) to CURRENT-IDENT. 
*** Compare this PERSON against all previously entered PERSONS 
*** to search for RELATIONSHIPS. 

perform COMPARE-TO-PREVTOUS varying PREVIOUS from 1 by 1 

until PREVIOUS not < CURRENT, 
read PEOPLE at end perform NULL. 
READ-IN-PEOPLE-EXIT. 
exit . 

NULL. 

exit. 
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COMPARE -TO-PREVIOUS . 

move IDENTIFIER of PERSON (PREVIOUS) to PREVIOUS -IDENT. 
*** Search for father, mother, or spouse relationship in 
*** either direction between this and PREVIOUS PERSON. 
*** Assume at most one RELATIONSHIP exists, 
move IS -FALSE to RELATION-LOOP-DONE, 
perform TRY-ALL -RELATIONSHIPS 

varying RELATIONSHIP from FATHER-IDENT by 1 
until RELATIONSHIP > SPOUSE-IDENT or RELATION-LOOP -IS-DONE. 
TRY-ALL -RELATIONSHIPS . 

if RELATIVE -IDENTIFIER of PERSON (CURRENT, RELATIONSHIP) - 
PREVIOUS-IDENT 
set FROM-INDEX to CURRENT 
set TO-INDEX to PREVIOUS 
perform LINK-RELATIVES 
move IS -TRUE to RELATION-LOOP -DONE 
else 

if CURRENT-IDENT = 

RELATIVE -IDENTIFIER of PERSON (PREVIOUS, RELATIONSHIP) 
set FROM-INDEX to PREVIOUS 
set TO-INDEX to CURRENT 
perform LINK-RELATIVES 
move IS -TRUE to RELATION-LOOP-DONE. 

LINK-RELATIVES. 

* establishes cross-indexing between immediately related PERSONS. 

if RELATIONSHIP - SPOUSE-IDENT 

move SPOUSE to THIS -EDGE 

perform LINK-ONE-WAY 

set TEMP-INDEX to FROM-INDEX 

set FROM-INDEX to TO-INDEX 

set TO-INDEX to TEMP-INDEX 

perform LINK-ONE-WAY 
else 

* RELATIONSHIP is father or mother 
move PARENT to THIS -EDGE 
perform LINK-ONE-WAY 

move CHILD to THIS-EDGE 
set TEMP-INDEX to FROM-INDEX 
set FROM-INDEX to TO-INDEX 
set TO-INDEX to TEMP-INDEX 
perform LINK-ONE-WAY. 

LINK-ONE-WAY. 
*** Establishes the NEIGHBOR-RECORD from one PERSON to another 
add 1 to NEIGHBOR-COUNT of PERSON (FROM-INDEX). 

set NEXT-NEIGHBOR to NEIGHBOR-COUNT of PERSON (FROM-INDEX). 
set NEIGHBOR-INDEX of PERSON (FROM-INDEX, NEXT -NEIGHBOR) 

to TO-INDEX. 
move THIS-EDGE 

to NEIGHBOR-EDGE of PERSON (FROM-INDEX, NEXT-NEIGHBOR). 
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PROMPT -AND-READ . 

* Issues prompt for user-request, reads in request, 

* blank-fills buffer, and skips to next line of input. 

display " ". 

display " 

display " Enter two person-identifiers (name or number),", 
display " separated by semicolon. Enter ""stop"" to stop.", 
move spaces to REQUEST -BUFFER, 
accept REQUEST -BUFFER. 

READ-AND-PROCESS -REQUEST . 
perform CHECK-REQUEST. 

*** Syntax check of request completed . Now either display error 
*** message or search for the two PERSONS. 

if ERROR-MESSAGE = REQUEST-OK 

perform PROCESS-LEGAL-REQUEST 
else 

display " Incorrect request format: ", ERROR-MESSAGE, 
perform PROMPT -AND -READ. 
READ-AND-PROCESS -REQUE ST-EXET. 
exit. 

CHECK-REQUEST. 

* Performs syntactic check on request in buffer 

* and fills in identifiers of the two requested persons. 

move zero to SEMICOLON-COUNT. 

inspect RE QUE ST -BUFFER tallying SEMICOLON-COUNT 

for all "; ". 
if SEMICOLON-COUNT not = 1 

move "must be exactly one semicolon." to ERROR-MESSAGE 
else 

move zero to LEADING-SPACES 

inspect RE QUE ST -BUFFER tallying LEADING-SPACES 

for leading spaces 
add 1 to LEADING-SPACES 

unstring REQUEST-BUFFER delimited by ";" 
into PERS0N1-IDENT, TEMP-IDENT 
with pointer LEADING-SPACES 
if PERS0N1-IDENT = spaces 

move "null field preceding semicolon." to ERROR-MESSAGE 
else 

if TEMP-IDENT = spaces 

move "null field following semicolon." to ERROR-MESSAGE 
else 

move zero to LEADING-SPACES 

inspect TEMP-IDENT tallying LEADING-SPACES 

for leading spaces 
add 1 to LEADING-SPACES 
unstring TEMP-IDENT into PERS0N2-IDENT 

with pointer LEADING-SPACES 
move REQUEST-OK to ERROR-MESSAGE. 
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PROCE SS -LEGAL-REQUE ST . 
*** search for requested PERSONS. 

move zero to PERSON 1-FOUND, PERS0N2-F0UND. 

perform SCAN-ALL-PERSONS varying CURRENT from 1 by 1 

until CURRENT > NUMBER-OF -PERSONS, 
if PERSON1 -FOUND = 1 and PERS0N2 -FOUND = 1 
*** Exactly one match for each PERSON - proceed to 

*** determine RELATIONSHIP, if any. 

if PERS0N1-INDEX = PERS0N2-INDEX 

if GENDER of PERSON (PERS0N1 -INDEX) = MALE 

display " ", NAME of PERSON (PERS0N1-INDEX) , 
is identical to himself." 
else 

display " ", NAME of PERSON (PERS0N1-INDEX) , 
" is identical to herself." 
else 

set ARG-PERS0N1-INDEX to PERSON1-INDEX 
set ARG-PERS0N2 -INDEX to PERSON2-INDEX 
call "FINDREL" using 

ARG-PERS0N1-INDEX, ARG-PERSON2-INDEX, PERSON-TABLE 
else 
*** either not found or more than one found 

perform MISSING-OR-DUPLICATE -PERSONS. 

SCAN-ALL-PERSONS . 

if PERS0N1-IDENT = NAME of PERSON (CURRENT) or 

IDENTIFIER of PERSON (CURRENT) 
set PERS0N1-INDEX to CURRENT 
add 1 to PERS0N1-F0UND. 
if PERS0N2-IDENT = NAME of PERSON (CURRENT) or 

IDENTIFIER of PERSON (CURRENT) 
set PERS0N2-INDEX to CURRENT 
add 1 to PERS0N2-F0UND. 

MISSING-OR-DUPLICATE-PERSONS . 
if PERS0N1-F0UND - zero 

display " First person not found." 
else 

if PERS0N1-F0UND > 1 

display " Duplicate names for first person - use", 
" numeric identifier.", 
if PERS0N2-F0UND = zero 

display " Second person not found." 
else 

if PERS0N2-F0UND > 1 

display " Duplicate names for second person - use" , 
" numeric identifier.". 
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* 


Compilation unit number 2 


identification division, 
program-id. FINDREL. 

Finds shortest path (if any) between two PERSONS and 
determines their RELATIONSHIP based on immediate relations 
traversed in path. PERSON array simulates a directed graph, 
and algorithm finds shortest path, based on following 
weights: PARENT -CHILD edge =1.0 
SPOUSE -SPOUSE edge =1.8 

environment division. 


configuration section, 
source-computer . VAX-1 1 . 
object-computer. VAX-11. 

data division. 

working- st or age section. 

* Define global objects 


01 


TRUTH-VALUES. 




05 IS-TRUE 

pic X 

value 

"T 

05 IS -FALSE 

pic X 

value 

"F 


* each PERSON'S record in the file identifies at most three 

* others directly related: father, mother, and spouse 
01 GIVEN-IDENTIF IERS . 

05 FATHER-IDENT pic 9 value 1. 
05 M0THER-IDENT pic 9 value 2. 
05 SP0USE-IDENT pic 9 value 3. 


01 


01 


GENDER-TYPE. 





05 MALE 

pic 

X 

value 

"M" 

05 FEMALE 

pic 

X 

value 

"F' 

RELATION-TYPE . 





05 PARENT 

pic 

9 

value 

1. 

05 CHILD 

pic 

9 

value 

2. 

05 SPOUSE 

pic 

9 

value 

3. 

05 SIBLING 

pic 

9 

value 

4. 

05 UNCLE 

pic 

9 

value 

5. 

05 NEPHEW 

pic 

9 

value 

6. 

05 COUSIN 

pic 

9 

value 

7. 

05 NULL -RELATION 

pic 

9 

value 

8. 
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* A node in the graph (= PERSON) has either already been reached, 

* is immediately adjacent to those reached, or farther away. 
01 REACHED-TYPE. 

05 REACHED pic 9 value 1. 

05 NEARBY pic 9 value 2. 

05 NOT -SEEN pic 9 value 3. 


01 SEARCH-TYPE. 
05 SEARCHING 
05 SUCCEEDED 
05 FAILED 

01 SIBLING-TYPE. 
05 STEP 
05 HALF 
05 FULL 


pic 9 value 1. 
pic 9 value 2. 
pic 9 value 3. 


pic 9 value 1, 
pic 9 value 2, 
pic 9 value 3. 


01 KEY-PERSON-TABLE. 

05 KEY-PERSON occurs 300 times 

indexed by KEY-INDEX, LATER-KEY-INDEX, PRIMARY-INDEX, 
FIRST-INDEX, LAST-INDEX, 
RECEIVE -INDEX, SEND-INDEX. 


10 RELATION-TO-NEXT 

10 PERSON-INDEX 

10 GENERATION-GAP 

10 PROXIMITY 

10 COUSIN-RANK 


pic 9. 

usage index, 
pic 999. 
pic 9. 
pic 999. 


01 


AUXILIARY-VARIABLES . 

these variables are used to find the shortest path 

05 WEIGHT-THIS-EDGE pic 99V9. 

05 DISTANCE -THRU-BASE-NODE pic 99999V9. 

05 SEARCH-STATUS pic 9. 

05 NEARBY-NODE usage index, occurs 300 times, 

indexed by THIS -NEARBY -INDEX, BEST-NEARBY-INDEX, LAST -NEARBY-INDEX. 

05 THIS-EDGE pic 9. 

05 NEXT-BASE -EDGE pic 9. 

05 MINIMAL -DISTANCE pic 9999999V9. 

05 DISPLAY-BUFFER pic X(70). 

05 DISPLAY-POINTER pic 99. 

05 NULL-IDENT pic 999 value 000. 

*** these variables are used to condense the path 
05 KEY-RELATION pic 9. 

05 LATER-KEY-RELATION pic 9. 
05 PRIMARY -RELATION pic 9. 

05 FIRST-RELATION pic 9. 

05 LAST-RELATION pic 9. 

05 NEXT -PRIMARY-RELATION pic 9. 
05 GAP-SIZE pic 999. 

05 ANOTHER-ELEMENT -POSSIBLE pic X. 

88 ANOTHER-ELEMENT-IS-POSSIBLE value "T" . 
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*** 


these variables are used to 

generate KEY-PERSONs and for DISPLAY 

05 GENERATION-COUNT 

pic 999. 

05 TEMP-NUMBER 

pic 999. 

05 THIS -COUSIN-RANK 

pic 999. 

05 THIS-PROXIMITY 

pic 9. 

05 THIS -GENDER 

pic X. 

05 THIS-GENERATION-GAP 

pic 999. 

05 SUFFIX-INDICATOR 

pic 9. 

05 TWO-DIGIT -FIELD 

pic Z9. 

05 INLAW 

pic X. 

88 RELATION-IS -INLAW 

value "T" . 

05 MALE -NAME -VALUES. 



05 


05 


05 


10 
10 
10 
10 
10 
10 
10 
10 


filler 
filler 
filler 
filler 
filler 
filler 
filler 
filler 


pic X(8 
pic X(8 
pic X(8 
pic X(8 
pic X(8 
pic X(8 
pic X(8 
pic X(8 


value 
value 
value 
value 
value 
value 
value 
value 


'father 

'son 

'husband 

'brother 

'uncle 

'nephew 

'cousin 

"null 


MALE -NAME -TABLE redefines MALE -NAME -VALUES. 

10 PRIMARY-MALE -NAME pic X(8) occurs 8 times 

indexed by MALE -INDEX. 
FEMALE-NAME-VALUE S . 


10 

filler 

pic X(8) 

value 

"mother 

10 

filler 

pic X(8) 

value 

"daughter" . 

10 

filler 

pic X(8) 

value 

"wife 

10 

filler 

pic X(8) 

value 

"sister 

10 

filler 

pic X(8) 

value 

"aunt 

10 

filler 

pic X(8) 

value 

"niece 

10 

filler 

pic X(8) 

value 

"cousin 

10 

filler 

pic X(8) 

value 

"null 


FEMALE -NAME-TABLE redefines FEMALE -NAME -VALUES. 
10 PRIMARY-FEMALE -NAME pic X(8) occurs 8 times 
indexed by FEMALE-INDEX. 
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linkage section. 

77 PARM-TARGET-INDEX pic 999. 

77 PARM-SOURCE -INDEX pic 999. 

01 PERSON-TABLE. 

05 NUMBER-OF -PERSONS usage index. 

05 PERSON occurs 300 times 

indexed by INDEX1, INDEX2, TARGET-INDEX, SOURCE -INDEX, 
BASE-NODE, THIS-NODE, NEXT-NODE. 
*** static information - filled from PEOPLE file: 
10 NAME pic X(20). 

10 IDENTIFIER pic 999. 

10 GENDER pic X. 

*** IDENTIFIERS of immediate relatives - father, mother, spouse 

10 IMMEDIATE -RELATIONS. 

15 RELATIVE -IDENTIFIER occurs 3 times indexed by RELATIONSHIP 

pic 999. 
*** pointers to immediate neighbors in graph 
10 NEIGHBOR-COUNT pic 99. 

10 NEIGHBOR-RECORD occurs 20 times indexed by THIS-NEIGHBOR. 
15 NEIGHBOR-INDEX usage index. 
15 NEIGHBOR-EDGE pic 9. 

*** data used when traversing graph to resolve user request: 
10 DISTANCE -FROM-SOURCE pic 99999V9. 
10 PATH-PREDECESSOR usage index. 

10 EDGE-TO-PREDECESSOR pic 9. 
10 REACHED-STATUS pic 9. 

*** data used to compute common genetic material 
10 DESCENDANT -IDENTIFIER pic 999. 
10 DESCENDANT-GENES pic 9V99999999. 

procedure division using 

PARM-TARGET-INDEX, PARM-SOURCE -INDEX, PERSON-TABLE. 
MAIN-LINE. 

set TARGET-INDEX to PARM-TARGET-INDEX. 
set SOURCE-INDEX to PARM-SOURCE-INDEX. 
*** initialize PERSON-array for processing - 
*** mark all nodes as not seen 

perform MARK-AS-NOT-SEEN varying THIS-NODE from 1 by 1 

until THIS-NODE > NUMBER-OF-PERSONS. 
set THIS-NODE to SOURCE-INDEX. 
*** mark source node as REACHED 

move REACHED to REACHED-STATUS of PERSON (THIS-NODE). 

move zero to DISTANCE -FROM-SOURCE of PERSON (THIS-NODE). 

*** no nearby nodes exist yet 

set LAST-NEARBY-INDEX to 1. 

set LAST-NEARBY-INDEX down by 1. 

if THIS-NODE = TARGET-INDEX 

move SUCCEEDED to SEARCH-STATUS 
else 

move SEARCHING to SEARCH-STATUS. 
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*** Loop keeps processing closes t- to- source, unREACHED node 
*** until target REACHED, or no more connected nodes. 

perform SEARCH-FOR-TARGET until SEARCH-STATUS not = SEARCHING. 

*** Shortest path between PERSONS now established. Next task is 
*** to translate path to English description of RELATIONSHIP, 
if SEARCH-STATUS = FAILED 

display " ", NAME of PERSON (TARGET-INDEX), " is not related to ", 
NAME of PERSON (SOURCE -INDEX) 
else 
*** success - parse path to find and display RELATIONSHIP 

perform RESOLVE-PATH-TO-ENGLISH 
call "COMGENES" using 

P ARM-SOURCE -INDEX, PARM-TARGET-INDEX, PERSON-TABLE. 
END-OF-FINDREL. 
exit program. 

MARK-AS -NOT-SEEN. 

move NOT-SEEN to REACHED-STATUS of PERSON (THIS-NODE). 

SEARCH-FOR-TARGET . 
*** Process all nodes adjacent to THIS-NODE 

perform PROCESS-ADJACENT -NODE varying THIS-NEIGHBOR from 1 by 1 
until THIS-NEIGHBOR > NEIGHBOR-COUNT of PERSON (THIS-NODE). 
*** All nodes adjacent to THIS-NODE are set. Now search for 
*** shortest-distance unREACHED (but NEARBY) node to process next, 
if LAST -NEARBY-INDEX = zero 

move FAILED to SEARCH-STATUS 
else 
*** determine next node to process 

move 9999999 to MINIMAL -DISTANCE 

perform FIND-CLOSEST-UNREACHED-NODE varying THIS -NEARBY-INDEX 
from 1 by 1 until THIS-NEARBY-INDEX > LAST-NEARBY-INDEX 

*** establish new THIS-NODE 

set THIS-NODE to NEARBY-NODE (BEST-NEARBY-INDEX) 
*** change THIS-NODE from being NEARBY to REACHED 

move REACHED to REACHED-STATUS of PERSON (THIS-NODE) 
*** remove THIS-NODE from NEARBY list 

set NEARBY-NODE (BEST-NEARBY-INDEX) to NEARBY-NODE (LAST-NEARBY-INDEX) 

set LAST-NEARBY-INDEX down by 1 

if THIS-NODE = TARGET-INDEX 

move SUCCEEDED to SEARCH-STATUS. 
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PROCESS-ADJACENT-NODE . 

set BASE-NODE to THIS-NODE. 

set NEXT-NODE to NEIGHBOR-INDEX of PERSON (BASE -NODE, THIS -NEIGHBOR) . 
move NEIGHBOR-EDGE of PERSON (BASE -NODE, THIS-NEIGHBOR) 
to NEXT -BASE -EDGE. 
*** NEXT-NODE is adjacent to last-REACHED node (= BASE-NODE). 
*** if NEXT-NODE already REACHED, do nothing. 
*** If previously seen, check whether path thru BASE -NODE is 
*** shorter than current path to NEXT -NODE, and if so re-link 
*** next to base. 

*** If not previously seen, link next to base node, 
if NEXT-BASE -EDGE = SPOUSE 

move 1.8 to WEIGHT-THIS-EDGE 
else 

move 1.0 to WEIGHT-THIS-EDGE. 
if REACHED-STATUS of PERSON (NEXT-NODE) not = REACHED 

add WEIGHT-THIS-EDGE, DISTANCE -FROM-SOURCE of PERSON (BASE -NODE) 

giving DISTANCE-THRU-BASE-NODE 
if REACHED-STATUS of PERSON (NEXT-NODE ) = NOT-SEEN 
move NEARBY to REACHED-STATUS of PERSON (NEXT-NODE) 
set IAST-NEARBY-INDEX up by 1 

set NEARBY-NODE (LAST-NEARBY-INDEX) to NEXT-NODE 
perform LINK-NEXT-NODE -TO-BASE-NODE 
else 
*** REACHED-STATUS = NEARBY 

if DISTANCE-THRU-BASE-NODE 

< DISTANCE-FROM-SOURCE of PERSON (NEXT-NODE) 
per f orm LINK-NEXT-NODE -TO-BASE -NODE . 

LINK-NEXT -NODE -TO-BASE-NODE . 
*** link next to base by re-setting its predecessor index to 
*** point to base, note type of edge, and re-set distance 
*** as it is through base node, 
move DISTANCE-THRU-BASE-NODE 

to DISTANCE-FROM-SOURCE of PERSON (NEXT-NODE), 
set PATH-PREDECESSOR of PERSON (NEXT-NODE) to BASE -NODE, 
move NEXT -BASE-EDGE to EDGE-TO-PREDECESSOR of PERSON (NEXT-NODE). 

FIND-CLOSEST-UNREACHED-NODE. 

set NEXT-NODE to NEARBY-NODE (THIS-NEARBY-INDEX) . 
if DISTANCE-FROM-SOURCE of PERSON (NEXT-NODE) < MINIMAL-DISTANCE 
set BEST-NEARBY-INDEX to THIS-NEARBY-INDEX 
move DISTANCE-FROM-SOURCE of PERSON (NEXT -NODE) to MINIMAL-DISTANCE. 
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RESOLVE-PATH-TO-ENGLISH. 
*** RESOLVE-PATH-TO-ENGLISH condenses the shortest path to a 
*** series of RELATIONSHIPS for which there are English 
*** descriptions. 

**.* Key persons are the ones in the RELATIONSHIP path which remain 
*** after the path is condensed. 

display "Shortest path between identified persons: ". 
set THIS -NODE to TARGET-INDEX. 
*** Display path and initialize KEY-PERSON array from path elements, 
perform TRAVERSE -SHORTEST-PATH varying KEY-INDEX from 1 by 1 

until THIS -NODE = SOURCE -INDEX, 
display " ", NAME of PERSON ( THIS -NODE ) . 
set PERSON-INDEX of KEY-PERSON (KEY-INDEX) to THIS-NODE. 
move NULL -RELATION to RELATION-TO-NEXT of KEY-PERSON ( KEY -INDEX ) . 
move NULL-RELATION to RELATION-TO-NEXT of KEY-PERSON (KEY-INDEX + 1), 

*** Resolve CHILD-PARENT and CHILD-SPOUSE -PARENT relations 
*** to SIBLING relations. 

perform FIND-SIBLINGS varying KEY-INDEX from 1 by 1 

until RELATION-TO-NEXT of KEY-PERSON (KEY-INDEX) = NULL -RELATION. 

*** Resolve CHILD-CHILD-. . . and PARENT-PARENT-. . . relations to 
*** direct descendant or ancestor relations. 

perform FIND-ANCESTORS -OR-DESCENDANTS varying KEY-INDEX from 1 by 1 
until RELATION-TO-NEXT of KEY-PERSON (KEY-INDEX) = NULL -RELATION. 

*** Resolve CHILD-SIBLING-PARENT to COUSIN, 
*** CHILD-SIBLING to NEPHEW, 

*** SIBLING -PARENT to UNCLE. 

perform FIND -COUSINS -NEPHEWS -UNCLES varying KEY-INDEX from 1 by 1 
until RELATION-TO-NEXT of KEY-PERSON (KEY-INDEX) = NULL -RELATION. 

*** Loop below will pick out valid adjacent strings of elements 

*** to be displayed. KEY-INDEX points to first element, 

*** LATER-KEY-INDEX to last element, and PRIMARY-INDEX to the 

*** element which determines the primary English word to be used. 

*** Associativity of adjacent elements in condensed table 

*** is based on English usage. 

set KEY-INDEX to 1. 

display " Condensed path:". 

perform CONSOLIDATE -ADJACENT-PERSONS 

until RELATION-TO-NEXT of KEY-PERSON (KEY-INDEX) - NULL-RELATION 

set THIS-NODE to PERSON-INDEX of KEY-PERSON (KEY-INDEX). 

display " ", NAME of PERSON (THIS-NODE). 
*** end of RESOLVE-PATH-TO-ENGLISH 
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TRAVERSE -SHORTEST-PATH. 

set PERSON-INDEX of KEY-PERSON (KEY-INDEX) to THIS-NODE. 
move FULL to PROXIMITY of KEY-PERSON (KEY-INDEX) . 
move EDGE-TO-PREDECESSOR of PERSON (THIS-NODE) 

to RELATION-TO-NEXT of KEY-PERSON ( KEY- INDEX ) . 
if EDGE-TO-PREDECESSOR of PERSON (THIS-NODE) = SPOUSE 

move zero to GENERATION-GAP of KEY-PERSON (KEY-INDEX) 
display " ", NAME of PERSON (THIS-NODE), " is spouse of" 
else 

move 1 to GENERATION-GAP of KEY-PERSON (KEY-INDEX) 
if EDGE-TO-PREDECESSOR of PERSON (THIS-NODE) = PARENT 

display " ", NAME of PERSON (THIS-NODE), " is parent of" 
else 
*** edge is child-type 

display " ", NAME of PERSON (THIS-NODE), " is child of", 
set THIS-NODE to PATH-PREDECESSOR of PERSON (THIS-NODE). 

FIND-SIBLINGS. 

if RELATION-TO-NEXT of KEY-PERSON (KEY-INDEX) = CHILD 
move RELATION-TO-NEXT of KEY-PERSON (KEY-INDEX + 1) 

to IATER-KEY-RELATION 
if LATER-KEY-RELATION = PARENT 
*** then found either full or half SIBLINGS 

perform SET-UP-FULL -HALF-SIBLING 
else 

if IATER-KEY-RELATION = SPOUSE and 

RELATION-TO-NEXT of KEY-PERSON (KEY-INDEX + 2) = PARENT 
*** then found step- sib lings 

move zero to GENERATION-GAP of KEY-PERSON (KEY-INDEX) 

move STEP to PROXIMITY of KEY-PERSON (KEY-INDEX) 

move SIBLING to RELATION-TO-NEXT of KEY-PERSON (KEY-INDEX) 
move 2 to GAP-SIZE 
perform CONDENSE -KEY-PERSONS. 

SET-UP-FULL-HALF-SIBLING. 
*** Determines whether two PERSONS are full siblings, i.e., 

*** have the same two parents . 

set INDEX1 to PERSON-INDEX of KEY-PERSON (KEY-INDEX), 
set INDEX2 to PERSON-INDEX of KEY-PERSON (KEY-INDEX + 2). 
if (NULL-IDENT not = 

RELATIVE -IDENTIFIER of PERSON (INDEX1, FATHER-IDENT ) 
and RELATIVE -IDENTIFIER of PERSON (INDEX1, MOTHER-IDENT)) 
and (RELATIVE -IDENTIFIER of PERSON (INDEX1, FATHER-IDENT) = 

RELATIVE -IDENTIFIER of PERSON (INDEX2, FATHER-IDENT)) 
and (RELATIVE -IDENTIFIER of PERSON (INDEX1, MOTHER-IDENT) = 
RELATIVE -IDENTIFIER of PERSON (INDEX2, MOTHER-IDENT)) 
move FULL to PROXIMITY of KEY-PERSON (KEY-INDEX) 
else 

move HALF to PROXIMITY of KEY-PERSON (KEY-INDEX), 
move zero to GENERATION-GAP of KEY-PERSON (KEY-INDEX), 

move SIBLING to RELATION-TO-NEXT of KEY-PERSON (KEY-INDEX), 
move 1 to GAP-SIZE, 
perform CONDENSE-KEY-PERSONS. 
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F IND-ANCESTORS -OR-DE S CENDANT S . 

if RELATION-TO-NEXT of KEY-PERSON (KEY-INDEX) = CHILD or PARENT 
perform NULL varying LATER-KEY-INDEX from KEY-INDEX by 1 

until RELATION-TO-NEXT of KEY-PERSON (LATER-KEY-INDEX) not = 
RELATION-TO-NEXT of KEY-PERSON (KEY-INDEX) 

set GENERATION-COUNT to LATER-KEY-INDEX 
set TEMP-NUMBER to KEY-INDEX 

subtract TEMP-NUMBER from GENERATION-COUNT 
if GENERATION-COUNT > 1 
*** compress generations 

move GENERATION-COUNT to GENERATION-GAP of KEY-PERSON (KEY-INDEX) 
subtract 1 from GENERATION-COUNT giving GAP-SIZE 
perform CONDENSE -KEY-PERSONS. 

FIND-COUSINS-NEPHEWS-UNCLES. 

move RELATION-TO-NEXT of KEY-PERSON (KEY-INDEX + 1) 

to LATER-KEY-RELATION 
if RELATION-TO-NEXT of KEY-PERSON (KEY-INDEX) = CHILD and 
LATER-KEY-RELATION = SIBLING 
*** then COUSIN or NEPHEW 

if RELATION-TO-NEXT of KEY-PERSON (KEY-INDEX + 2) = PARENT 

perform FOUND-COUSIN 
else 
*** found NEPHEW 

move PROXIMITY of KEY-PERSON (KEY-INDEX + 1) to 

PROXIMITY of KEY-PERSON (KEY-INDEX) 
move NEPHEW to RELATION-TO-NEXT of KEY-PERSON (KEY-INDEX) 
move 1 to GAP-SIZE 
perform CONDENSE-KEY-PERSONS 
else 

if RELATION-TO-NEXT of KEY-PERSON (KEY-INDEX) = SIBLING and 
LATER-KEY-RELATION = PARENT 
*** then found UNCLE 

move GENERATION-GAP of KEY-PERSON (KEY-INDEX + 1) to 

GENERATION-GAP of KEY-PERSON (KEY-INDEX) 
move UNCLE to RELATION-TO-NEXT of KEY-PERSON (KEY-INDEX) 
move 1 to GAP-SIZE 
perform CONDENSE-KEY-PERSONS. 
FOUND-COUSIN. 

if GENERATION-GAP of KEY-PERSON (KEY-INDEX) 

< GENERATION-GAP of KEY-PERSON (KEY-INDEX + 2) 
move GENERATION-GAP of KEY-PERSON (KEY-INDEX) 
to COUSIN-RANK of KEY-PERSON (KEY-INDEX) 
else 

move GENERATION-GAP of KEY-PERSON (KEY-INDEX + 2) 
to COUSIN-RANK of KEY-PERSON (KEY-INDEX) . 
*** subtract moves in absolute value since GENERATION-GAP is unsigned 
subtract GENERATION-GAP of KEY-PERSON (KEY-INDEX + 2) 

from GENERATION-GAP of KEY-PERSON (KEY-INDEX), 
move PROXIMITY of KEY-PERSON (KEY-INDEX +1) 

to PROXIMITY of KEY-PERSON (KEY-INDEX), 
move COUSIN to RELATION-TO-NEXT of KEY-PERSON (KEY-INDEX), 
move 2 to GAP-SIZE, 
perform CONDENSE-KEY-PERSONS. 
NULL. 

exit. 
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CONDENSE -KEY-PERSONS . 
*** CONDENSE-KEY-PERSONS condenses superfluous entries from the 

*** KEY-PERSON array, starting at KEY-INDEX, 

set RECEIVE-INDEX to KEY-INDEX, 
set RECEIVE-INDEX up by 1. 
set SEND-INDEX to RECEIVE-INDEX. 
set SEND-INDEX up by GAP-SIZE. 

perform SLIDE -IT-DOWN varying RECEIVE-INDEX from RECEIVE-INDEX by 1 
until RELATION-TO-NEXT of KEY-PERSON (RECEIVE-INDEX - 1) 
= NULL-RELATION. 
SLIDE -IT-DOWN. 

move KEY-PERSON (SEND-INDEX) to KEY-PERSON (RECEIVE-INDEX). 
set SEND-INDEX up by 1. 

CONSOLIDATE -ADJACENT -PERSONS . 

move RELATION-TO-NEXT of KEY-PERSON (KEY-INDEX) to KEY-RELATION. 

set LATER-KEY-INDEX, PRIMARY-INDEX to KEY-INDEX. 

if RELATION-TO-NEXT of KEY-PERSON (KEY-INDEX + 1) not = NULL-RELATION 

perform SEEKHtfULTI -ELEMENT-COMBINATION, 
set FIRST-INDEX to KEY-INDEX, 
set LAST-INDEX to LATER-KEY-INDEX, 
perform DISPLAY-RELATION, 
set KEY-INDEX to LATER-KEY-INDEX, 
set KEY-INDEX up by 1. 

SEEK-MULTI -ELEMENT-COMBINATION. 

move IS -TRUE to ANOTHER-ELEMENT-POSSIBLE. 
if KEY-RELATION = SPOUSE 

set LATER-KEY-INDEX up by 1 
set PRIMARY-INDEX up by 1 

if RELATION-TO-NEXT of KEY-PERSON (LATER-KEY-INDEX) 
= SIBLING or COUSIN 
*** then nothing can follow spouse-sibling or spouse-cousin 

move IS -FALSE to ANOTHER-ELEMENT-POSSIBLE. 
*** PRIMARY-INDEX is now correctly set. Next if-statement 
*** determines if a following SPOUSE relation should be 
*** appended to this combination or left for the next 
*** combination. 

if RELATION-TO-NEXT of KEY-PERSON (PRIMARY-INDEX + 1) = SPOUSE 
and ANOTHER-ELEMENT-IS-POSSIBLE 
*** Only a SPOUSE can follow a Primary 

*** check primary preceding and following SPOUSE. 

move RELATION-TO-NEXT of KEY-PERSON (PRIMARY-INDEX) 

to PRIMARY-RELATION 
move RELATION-TO-NEXT of KEY-PERSON (PRIMARY-INDEX +2) 

to NEXT-PRIMARY-RELATION 
if (NEXT -PRIMARY-RELATION = NEPHEW or COUSIN or NULL-RELATION) 
or (PRIMARY -RELATION = NEPHEW) 
or ( (PRIMARY-RELATION = SIBLING or PARENT) 

and NEXT-PRIMARY-RELATION not = UNCLE ) 
*** then append following SPOUSE with this combination, 

set LATER-KEY-INDEX up by 1. 
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DISPLAY-RELATION. 
*** DISPLAY-RELATION takes 1, 2, or 3 adjacent elements in the 
*** condensed table and generates the English description of 
*** the relation between the first and last + 1 elements. 

move RELATION-TO-NEXT of KEY-PERSON (FIRST-INDEX) 

to FIRST-RELATION, 
move RELATION-TO-NEXT of KEY-PERSON (LAST-INDEX) 

to LAST-RELATION, 
move RELATION-TO-NEXT of KEY-PERSON (PRIMARY-INDEX) 
to PRIMARY-RELATION. 
*** set THIS -PROXIMITY 

if (PRIMARY-RELATION = PARENT and FIRST-RELATION = SPOUSE) or 
(PRIMARY-RELATION = CHILD and LAST-RELATION = SPOUSE) 
move STEP to THIS -PROXIMITY 
else 

if PRIMARY-RELATION = SIBLING or UNCLE or NEPHEW or COUSIN 

move PROXIMITY of KEY-PERSON (PRIMARY-INDEX) to THIS -PROXIMITY 
else 

move FULL to THIS -PROXIMITY. 
*** set THIS -GENERATION-GAP 

if PRIMARY-RELATION = PARENT or CHILD or UNCLE or NEPHEW or COUSIN 
move GENERATION-GAP of KEY-PERSON (PRIMARY -INDEX) 
to THIS -GENERATION-GAP 
else 

move zero to THIS -GENERATION-GAP. 
*** set INLAW 

if (FIRST-RELATION = SPOUSE) and 

(PRIMARY-RELATION = SIBLING or CHILD or NEPHEW or COUSIN) 
move IS -TRUE to INLAW 
else 

if (LAST-RELATION = SPOUSE) and 

(PRIMARY-RELATION = SIBLING or PARENT or UNCLE or COUSIN) 
move IS -TRUE to INLAW 
else 

move IS-FALSE to INLAW. 
*** set THIS -COUSIN-RANK 

if PRIMARY-RELATION = COUSIN 

move COUSIN-RANK of KEY-PERSON (PRIMARY-INDEX) to THIS-COUS IN-RANK 
else 

move zero to THIS-COUS IN-RANK. 
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*** parameters are set - now generate display* 

set THIS-NODE to PERSON-INDEX of KEY-PERSON (FIRST-INDEX), 
move spaces to DISPLAY-BUFFER, 
move 1 to DISPLAY-POINTER. 

string " ", NAME of PERSON (THIS-NODE), " is " 
delimited by size 

into DISPIAY-BUFFER with pointer DISPLAY-POINTER, 
if PRIMARY-RELATION = PARENT or CHILD or UNCLE or NEPHEW 

perform GENERATE-GENERATION-QUALIFIER 
else 

if (PRIMARY-RELATION = COUSIN) and (THIS-COUS IN-RANK > 1) 
move THIS-COUSIN-RANK to TWO-DIGIT-FIELD 
string TWO-DIGIT-FIELD delimited by size into DISPLAY-BUFFER 

with pointer DISPLAY-POINTER 
divide THIS-COUSIN-RANK by 10 giving TEMP-NUMBER 

remainder SUFFIX-INDICATOR 
if SUFFIX-INDICATOR = 1 

string "st " delimited by size 

into DISPLAY-BUFFER with pointer DISPLAY-POINTER 
else if SUFFIX-INDICATOR = 2 

string "nd " delimited by size 

into DISPLAY-BUFFER with pointer DISPLAY-POINTER 
else if SUFFIX-INDICATOR = 3 

string "rd " delimited by size 

into DISPLAY-BUFFER with pointer DISPLAY-POINTER 
else 

string "th " delimited by size 

into DISPLAY-BUFFER with pointer DISPLAY-POINTER. 

if THIS-PROXIMITY = STEP 

string "step-" delimited by size 

into DISPLAY-BUFFER with pointer DISPLAY-POINTER 
else 

if THIS-PROXIMITY - HALF 

string "half-" delimited by size 

into DISPLAY-BUFFER with pointer DISPLAY-POINTER. 

set THIS-NODE to PERSON-INDEX of KEY-PERSON (FIRST-INDEX), 
move GENDER of PERSON (THIS-NODE) to THIS-GENDER. 
set MALE-INDEX, FEMALE-INDEX to PRIMARY-RELATION, 
if THIS-GENDER = MALE 

string PRIMARY-MALE-NAME (MALE-INDEX) delimited by space 
into DISPLAY-BUFFER with pointer DISPLAY-POINTER 
else 

string PRIMARY-FEMALE -NAME (FEMALE -INDEX) delimited by space 
into DISPLAY-BUFFER with pointer DISPLAY-POINTER. 

if RELATION-IS -INLAW 

string "-in-law" delimited by size 

into DISPLAY-BUFFER with pointer DISPLAY-POINTER. 
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if (PRIMARY-RELATION - COUSIN) and (THIS -GENERATION-GAP > 0) 
if THIS -GENERATION-GAP > 1 

move THIS-GENERATION-GAP to TWO-DIGIT-FIELD 
string " ", TWO-DIGIT-FIELD, " times removed" 
delimited by size 

into DISPLAY-BUFFER with pointer DISPLAY-POINTER 
else 

string " once removed" delimited by size 

into DISPLAY-BUFFER with pointer DISPLAY-POINTJER. 

string " of" delimited by size 

into DISPLAY-BUFFER with pointer DISPLAY-POINTER, 
display DISPLAY-BUFFER. 

GENERATE-GENERATION-QUALIF IER. 

if THIS-GENERATION-GAP not < 3 

string "great" delimited by size 

into DISPLAY-BUFFER with pointer DISPLAY-POINTER 
if THIS-GENERATION-GAP > 3 

subtract 2 from THIS-GENERATION-GAP giving TWO-DIGIT-FIELD 
string "*", TWO-DIGIT-FIELD, "-" delimited by size 
into DISPLAY-BUFFER with pointer DISPLAY-POINTER 
else 

string "-" delimited by size 

into DISPLAY-BUFFER with pointer DISPLAY-POINTER, 
if THIS-GENERATION-GAP not < 2 

string "grand-" delimited by size 

into DISPLAY-BUFFER with pointer DISPLAY-POINTER. 
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* 


Compilation unit number 3 


identification division, 
program-id. COMGENES. 

COMGENES assumes that each ancestor contributes 
half of the genetic material to a PERSON. It finds common 
ancestors between two PERSONS and computes the expected 
value of the PROPORTION of common material. 


environment division. 

configuration section, 
sour ce- computer . VAX-1 1 . 
object-computer. VAX-11. 

data division. 

working- st or age section. 


01 


RELATION-TYPE. 




05 

PARENT 

pic 9 

value 

1 

05 

CHILD 

pic 9 

value 

2 

05 

SPOUSE 

pic 9 

value 

3 

05 

SIBLING 

pic 9 

value 

4 

05 

UNCLE 

pic 9 

value 

5 

05 

NEPHEW 

pic 9 

value 

6 

05 

COUSIN 

pic 9 

value 

7 

05 

NULL-RELATION 

pic 9 

value 

8 


1 AUXILIARY-VARIABLE S . 
05 COMMON-PROPORTION 
05 MATCH-IDENTIFIER 
05 TEN-DIGIT-FIELD 


pic 9V9999999999. 

pic 999. 

pic 9.999999999. 


01 STACKED-VARIABLES. 
*** used to simulate recursion 

05 STACK-ENTRY occurs 50 times indexed by STACK-INDEX. 


10 PROPORTION 

10 THIS-CONTRIBUTION 

10 ALREADY-COUNTED 

10 PERSON-INDEX 

10 NEXT-NEIGHBOR 


pic 9V9999999999. 
pic 9V9999999999. 
pic 9V9999999999. 
usage index, 
pic 999. 
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linkage section. 

77 PARM-INDEX1 pic 999. 

77 PARM-INDEX2 pic 999. 

01 PERSON-TABLE. 

05 NUMBER-OF -PERSONS usage index. 

05 PERSON occurs 300 times indexed by 
INDEX1, INDEX2, THIS-NODE. 
*** static information - filled from PEOPLE file: 
10 NAME pic X(20). 

10 IDENTIFIER pic 999. 

10 GENDER pic X. 

*** IDENTIFIERS of immediate relatives - father, mother, spouse 

10 IMMEDIATE -RELATIONS. 

15 RELATIVE -IDENTIFIER occurs 3 times indexed by RELATIONSHIP 

pic 999. 
*** pointers to immediate neighbors in graph 
10 NEIGHBOR-COUNT. pic 99. 

10 NEIGHBOR-RECORD occurs 20 times indexed by THIS -NEIGHBOR. 
15 NEIGHBOR-INDEX usage index. 
15 NEIGHBOR-EDGE pic 9. 

*** data used when traversing graph to resolve user request: 
10 DISTANCE -FROM-SOURCE pic 99999V9. 
10 PATH-PREDECESSOR usage index. 

10 EDGE-TO-PREDECESSOR pic 9. 
10 REACHED-STATUS pic 9. 

*** data used to compute common genetic material 
10 DESCENDANT -IDENTIFIER pic 999. 
10 DESCENDANT-GENES pic 9V99999999. 
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procedure division using 

PARM-INDEXl, PARM-INDEX2, PERSON-TABLE. 
MAIN -LINE. 

set INDEX1 to PARM-INDEXl. 
set INDEX2 to PARM-INDEX2. 
*** First zero out all ancestors to allow adding. This is necessary 
*** because there might be two paths to an ancestor, 
set STACK-INDEX to 1. 

set PERSON-INDEX (STACK-INDEX) to INDEX1. 
move zero to NEXT -NEIGHBOR (STACK-INDEX), 
perform ZERO-PROPORTION until STACK-INDEX < 1. 

*** now mark with shared PROPORTION 

move IDENTIFIER of PERSON (INDEX1) to MATCH-IDENTIFIER. 

set STACK-INDEX to 1. 

set PERSON-INDEX (STACK-INDEX) to INDEXl. 

move zero to NEXT -NEIGHBOR (STACK-INDEX). 

move 1.0 to PROPORTION (STACK-INDEX). 

perform MARK-PROPORTION until STACK-INDEX < 1. 
*** traverse ancestor tree for INDEX2, summing overlap 
*** with marked tree of INDEXl 

move zero to COMMON-PROPORTION 

set STACK-INDEX to 1. 

set PERSON-INDEX (STACK-INDEX) to INDEX2. 

move IDENTIFIER of PERSON (INDEXl) to MATCH-IDENTIFIER. 

move zero to NEXT -NEIGHBOR (STACK-INDEX) . 

move 1.0 to PROPORTION (STACK-INDEX). 

move zero to ALREADY-COUNTED (STACK-INDEX). 

perform CHECK-COMMON-PROPORTION until STACK-INDEX < 1. 

move COMMON-PROPORTION to TEN-DIGIT-FIELD. 

display " Proportion of common genetic material = ", TEN-DIGIT -FIELD, 
END-OF-COMGENES. 

exit program. 

ZERO-PROPORTION. 
*** ZERO -PROPORTION recursively seeks out all ancestors and 
*** zeros them out . 

set THIS -NODE to PERSON-INDEX (STACK-INDEX), 
if NEXT-NEIGHBOR (STACK-INDEX) = zero 

move zero to DESCENDANT-GENES of PERSON (THIS-NODE) 
move 1 to NEXT-NEIGHBOR (STACK-INDEX), 

perform NULL 

varying THIS-NEIGHBOR from NEXT-NEIGHBOR (STACK-INDEX) by 1 
until THIS-NEIGHBOR > NEIGHBOR-COUNT (THIS-NODE) 

or NEIGHBOR-EDGE (THIS-NODE, THIS-NEIGHBOR) = PARENT, 
if THIS-NEIGHBOR > NEIGHBOR-COUNT (THIS-NODE) 
*** then no more ancestors 

set STACK-INDEX down by 1 
else 
*** set up for next ancestor 

set NEXT-NEIGHBOR (STACK-INDEX) to THIS-NEIGHBOR 

add 1 to NEXT-NEIGHBOR (STACK-INDEX) 

set STACK-INDEX up by 1 

set PERSON-INDEX (STACK-INDEX) 

to NEIGHBOR-INDEX (THIS-NODE, THIS-NEIGHBOR) 
move zero to NEXT -NEIGHBOR (STACK-INDEX). 
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MARK-PROPORTION. 
*** MARK-PROPORTION recursively seeks out all ancestors and 
*** marks them with the sender's PROPORTION of shared 
*** genetic material. This PROPORTION is diluted by one-half 
*** for each generation. 

set THIS-NODE to PERSON-INDEX (STACK-INDEX), 
if NEXT-NEIGHBOR (STACK-INDEX) = zero 
move MATCH-IDENTIFIER 

to DESCENDANT -IDENTIFIER of PERSON (THIS-NODE) 
add PROPORTION (STACK-INDEX) 

to DESCENDANT-GENES of PERSON (THIS-NODE) 

move 1 to NEXT-NEIGHBOR (STACK-INDEX), 
perform NULL 

varying THIS-NEIGHBOR from NEXT-NEIGHBOR (STACK-INDEX) by 1 
until THIS-NEIGHBOR > NEIGHBOR-COUNT (THIS-NODE) 

or NEIGHBOR-EDGE (THIS-NODE, THIS-NEIGHBOR) = PARENT, 
if THIS-NEIGHBOR > NEIGHBOR-COUNT (THIS-NODE) 
*** then no more ancestors 

set STACK-INDEX down by 1 
else 
*** set up for next ancestor 

set NEXT-NEIGHBOR (STACK-INDEX) to THIS-NEIGHBOR 

add 1 to NEXT-NEIGHBOR (STACK-INDEX) 

set STACK-INDEX up by 1 

set PERSON-INDEX (STACK-INDEX) 

to NEIGHBOR-INDEX (THIS-NODE, THIS-NEIGHBOR) 
move zero to NEXT-NEIGHBOR (STACK-INDEX) 
divide PROPORTION (STACK-INDEX - 1) by 2 giving 
PROPORTION (STACK-INDEX) . 
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CHECK-COMMON-PROPORTION . 
*** CHECK-COMMON-PROPORTION searches all the ancestors of 
*** CHECK-INDEX to see if any have been marked, and if so 
*** adds the appropriate amount to COMMON-PROPORTION. 

set THIS -NODE to PERSON-INDEX (STACK-INDEX), 
if NEXT-NEIGHBOR (STACK-INDEX) = zero 
move 1 to NEXT -NEIGHBOR (STACK-INDEX) 

if DESCENDANT-IDENTIFIER of PERSON (THIS-NODE) = MATCH-IDENTIFIER 
*** Increment COMMON-PROPORTION by the contribution of 

*** this common ancestor, but discount for the contribution 

*** of less remote ancestors already counted. 

multiply DESCENDANT-GENES of PERSON (THIS-NODE) 
by PROPORTION (STACK-INDEX) 
giving THIS-CONTRIBUTION (STACK-INDEX) 
compute COMMON-PROPORTION = COMMON-PROPORTION 
+ THIS-CONTRIBUTION (STACK-INDEX) 
- ALREADY-COUNTED (STACK-INDEX) 
else 

move zero to THIS-CONTRIBUTION (STACK-INDEX), 
perform NULL 

varying THIS-NEIGHBOR from NEXT -NEIGHBOR (STACK-INDEX) by 1 
until THIS-NEIGHBOR > NEIGHBOR-COUNT (THIS-NODE) 

or NEIGHBOR-EDGE (THIS-NODE, THIS-NEIGHBOR) - PARENT, 
if THIS-NEIGHBOR > NEIGHBOR-COUNT (THIS-NODE) 
*** then no more ancestors 

set STACK-INDEX down by 1 
else 
*** set up for next ancestor 

set NEXT -NEIGHBOR (STACK-INDEX) to THIS-NEIGHBOR 

add 1 to NEXT-NEIGHBOR (STACK-INDEX) 

set STACK-INDEX up by 1 

set PERSON-INDEX (STACK-INDEX) 

to NEIGHBOR-INDEX (THIS-NODE, THIS-NEIGHBOR) 
move zero to NEXT-NEIGHBOR (STACK-INDEX) 
divide PROPORTION (STACK-INDEX - 1) by 2 giving 

PROPORTION ( STACK-INDEX ) 
divide THIS-CONTRIBUTION (STACK-INDEX - 1) by 4 giving 
ALREADY-COUNTED (STACK-INDEX). 

NULL. 

exit . 
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6.0 FORTRAN 


In keeping with the general convention of the examples, language- supplied 
keywords and identifiers are written in lower case in the program. To conform 
strictly to the FORTRAN standard, however, programs must use only upper-case 
letters. 


program RELATE 
c Establish global constants 

integer MAXPRS, NAMLEN, IDLEN, BUFLEN, 

1 MS GLEN, MAXNBR, MAXGVN 

parameter (MAXPRS = 300, NAMLEN = 20, IDLEN = 3, BUFLEN = 60, 

1 MSGLEN = 40, MAXNBR = 20, MAXGVN = 3) 

character NULLID* (IDLEN) 
parameter (NULLID = '000') 

c Each PERSON'S record in the file identifies at most three 
c others directly related: father, mother, and spouse 

integer FATHID, MOTHID, SPOUID 

parameter (FATHID = 1, MOTHID = 2, SPOUID = 3) 

character REQ0K*10, REQSTP*4 

parameter (REQ0K = 'Request OK', REQSTP = 'stop') 

character MALE*1, FEMALE*1 
parameter (MALE = 'M', FEMALE = 'F') 

integer PARENT, CHILD, SPOUSE, SIBLNG, 

1 UNCLE, NEPHEW, COUSIN, NULLRL 

parameter (PARENT = 1, CHILD = 2, SPOUSE = 3, SIBLNG = 4, 

1 UNCLE = 5, NEPHEW = 6, COUSIN = 7, NULLRL = 8) 

c These common blocks hold the PERSON array, which is global to 
c the entire program. 

common /PERNUM/ NBRCNT, NBRDEX, NBREDG, DSTSRC, PATHPR, 

1 EDGPRD, RCHST, DSCGEN, NUMPER 

common /PERCHR/ NAME, IDENT, GENDER, RELID, DSCID 
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c The following data Items constitute the PERSON array, which 

c is the central repository of information about inter-relationships 

c static information - filled from PEOPLE file 

character* (NAMLEN) NAME (MAXPRS) 

character* (IDLEN) IDENT (MAXPRS) 

character*! GENDER (MAXPRS) 

c IDENTs of immediate relatives - father, mother, spouse 

character* (IDLEN) RELID (MAXPRS, MAXGVN) 
c pointers to immediate neighbors in graph 

integer NBRCNT (MAXPRS) 

integer NBRDEX (MAXPRS, MAXNBR) 

integer NBREDG (MAXPRS, MAXNBR) 

c data used when traversing graph to resolve user request: 

real DSTSRG (MAXPRS) 

integer PATHPR (MAXPRS) 

integer EDGPRD (MAXPRS) 

integer RCHST (MAXPRS) 

c data used to compute common genetic material 

character* (IDLEN) DSCID (MAXPRS) 

real DSC GEN (MAXPRS) 

c NUMPER keeps track of the actual number of persons 
integer NUMPER 

c *** en d f declarations for common data *** 

c These variables are used when establishing the PERSON array 
c from the PEOPLE file. 

integer CURRNT, PRVDEX 

character* (IDLEN) PREVID, CURRID 

integer RELSHP 


c 

These variables are used 

to accept and resolve requests for 

c 

RELSHP information. 



integer 

BUFDEX, SEMLOC 


character*(BUFLEN) 

REQBUF 


character* (NAMLEN) 

P1IDNT, P2IDNT 


integer 

P1FND, P2FND 


character* (MSGLEN) 

ERRMSG 


integer 

P1DEX, P2DEX 


character*7 

PRNOUN 
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c *** execution of main sequence begins here *** 

open (unit=10, file='PEOPLE.DAT', status-" old', form-' format ted') 

c This loop reads in the PEOPLE file and constructs the PERSON 

c array from it (one PERSON = one record = one array entry), 

c As records are read in, links are constructed to represent the 

c PARENT-CHILD or SPOUSE relationship. The array then implements 

c a directed graph which is used to satisfy subsequent user 

c requests. The file is assumed to be correct - no validation 

c is performed on it. 

do 110 CURRNT-1, MAXPRS 
c copy direct information from file to array 

read (unit»10, fmt-'(a20, a3, al, 3a3)', end-Ill) 

1 NAME(CURRNT), IDENT (CURRNT), GENDER(CURRNT) , 

2 ((RELID(CURRNT,ITEMP), ITEMP-FATHID , SPOUID)) 
c Location of adjacent persons as yet undetermined 

NBRCNT (CURRNT) = 
c Descendants as yet undetermined 

DSCID (CURRNT) = NULLID 
c Compare this PERSON against all previously entered PERSONS 
c to search for relationships . 
CURRID - IDENT (CURRNT) 
do 120 PRVDEX = 1, CURRNT -1 
PREVTD - IDENT (PRVDEX) 
c Search for father, mother, or spouse relationship in 

c either direction between this and previous PERSON, 

c Assume at most one relationship exists, 

do 130 RELSHP - FATHID, SPOUID 

if (PREVID .eq. RELID (CURRNT, RELSHP)) then 
call LNKREL (CURRNT, RELSHP, PRVDEX) 
goto 131 
else if (CURRID .eq. RELID (PRVDEX, RELSHP)) then 
call LNKREL (PRVDEX, RELSHP, CURRNT) 
goto 131 
end if 

130 continue 

131 continue 
120 continue 

110 continue 

111 continue 

NUMPER - CURRNT - 1 

close (unit-10, status-' keep') 

c PERSON array is now loaded and edges between immediate relatives 
c (PARENT-CHILD or SPOUSE -SPOUSE) are established . 


Page 102 


c Loop accepts requests and finds relationship (if any) 
c between pairs of PERSONS. 

200 continue 

call PROMPT (REQBUF) 

if (REQBUF .eq. REQSTP) goto 201 

call CHKRQS (REQBUF, ERRMSG, PlIDNT, P2IDNT) 

c Syntax check of request completed. Now either display error 
c message or search for the two PERSONS. 

if (ERRMSG .eq. REQOK) then 
c Request syntactically correct - search for requested PERSONS 

call SEEKPR (PlIDNT, P2IDNT, P1DEX, P2DEX, 
1 P1FND, P2FND) 

if (P1FND .eq. 1 .and. P2FND .eq. 1) then 
c Exactly one match for each PERSON - proceed to 

c determine relationship, if any. 

if (P1DEX .eq. P2DEX) then 

if (GENDER (P1DEX) .eq. MALE) then 

PRNOUN = 'himself 
else 

PRNOUN = 'herself 
end if 

write (unit=*, fmt=9002) NAME (P1DEX), PRNOUN 
9002 format (a22, ' is identical to ', a7, '.') 

else 

call FINDRL (P1DEX, P2DEX) 
end if 
else 
c either not found or more than one found 

if (P1FND .eq. 0) then 

write (unit=*, fmt='(" First person not found.")') 
else if (P1FND .gt. 1) then 
write (unit=*, 

1 fmt='(" Duplicate names for first person", 

2 " - use numeric identifier.")') 
end if 

if (P2FND .eq. 0) then 

write (unit**, fmt='(" Second person not found.")') 
else if (P2FND .gt. 1) then 

write (unit=*, 

1 fmt='(" Duplicate names for second person", 

2 " - use numeric identifier.")') 
end if 

end if 
c end processing of syntactically legal request 

else 

write (unit=*, fmt=9004) ERRMSG 
9004 format (' Incorrect request format: ', a40) 
end if 
goto 200 

201 continue 

write (unit=*, fmt='(" End of relation-finder.")') 
c End of main line of RELATE 
end 
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c procedures under RELATE 

subroutine LNKREL (FRMDEX, RELSHP, TODEX) 
c establishes cross- indexing between immediately related PERSONS 
integer FRMDEX, TODEX, RELSHP 


c Each PERSON'S record in the file identifies at most three 
c others directly related: father, mother, and spouse 

integer FATHID, MOTHID, SPOUID 

parameter (FATHID = 1, MOTHID - 2, SPOUID = 3) 

integer PARENT, CHILD, SPOUSE, SIBLNG, 

1 UNCLE, NEPHEW, COUSIN, NULLRL 

parameter (PARENT = 1, CHILD = 2, SPOUSE = 3, SIBLNG = 

1 UNCLE = 5, NEPHEW = 6, COUSIN = 7, NULLRL = 

if (RELSHP .eq. SPOUID) then 

call LNKONE (FRMDEX, SPOUSE, TODEX) 

call LNKONE (TODEX, SPOUSE, FRMDEX) 
else 
c RELSHP is father or mother 

call LNKONE (FRMDEX, PARENT, TODEX) 

call LNKONE (TODEX, CHILD, FRMDEX) 
end if 
end 


4, 
8) 
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subroutine LNKONE (FRMDEX, THSEDG, TODEX) 
c Establishes the NBR pointers from one PERSON to another 
integer FRMDEX, TODEX, THSEDG 

integer MAXPRS, NAMLEN, IDLEN, BUFLEN, 
1 MSGLEN, MAXNBR, MAXGVN 

parameter (MAXPRS = 300, NAMLEN = 20, IDLEN = 3, BUFLEN = 60, 
1 MSGLEN = 40, MAXNBR = 20, MAXGVN = 3) 

character NULLID*( IDLEN) 
parameter (NULL ID = '000') 

c These common blocks hold the PERSON array, which is global to 
c the entire program. 

common /PERNUM/ NBRCNT, NBRDEX, NBREDG, DSTSRC, PATHPR, 
1 EDGPRD, RCHST, DSCGEN, NUMPER 

common /PERCHR/ NAME, IDENT, GENDER, RELID, DSCID 

c The following data items constitute the PERSON array, which 

c is the central repository of information about inter-relationships 

c static information - filled from PEOPLE file 

character* (NAMLEN) NAME (MAXPRS) 

character* (IDLEN) IDENT (MAXPRS) 

character*l GENDER (MAXPRS) 

c IDENTs of immediate relatives - father, mother, spouse 

character* (IDLEN) RELID (MAXPRS, MAXGVN) 
c pointers to immediate neighbors in graph 

integer NBRCNT (MAXPRS ) 

integer NBRDEX (MAXPRS, MAXNBR) 

integer NBREDG (MAXPRS, MAXNBR) 

c data used when traversing graph to resolve user request: 

real DSTSRC (MAXPRS) 

integer PATHPR (MAXPRS) 

integer EDGPRD (MAXPRS) 

integer RCHST (MAXPRS) 

c data used to compute common genetic material 

character* (IDLEN) DSCID (MAXPRS) 

real DSCGEN (MAXPRS) 

c NUMPER keeps track of the actual number of persons 
integer NUMPER 

c *** end of declarations for common data *** 

ITEMP - NBRCNT (FRMDEX) + 1 
NBRCNT (FRMDEX) - ITEMP 
NBRDEX (FRMDEX, ITEMP) = TODEX 
NBREDG (FRMDEX, ITEMP) = THSEDG 
end 
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subroutine PROMPT (REQBUF) 
c Issues prompt for user-request, reads in request, 
c blank-fills buffer, and skips to next line of input. 

character* (*) REQBUF 

write (unit=*, fmt«9001) 
9001 format (/,' ' 

1 /,' Enter two person-identifiers (name or number),' 

2 /,' separated by semicolon. Enter "stop" to stop.') 

c *** NOTE THAT THIS IS NOT A STANDARD WAY TO READ A LINE FROM 
c *** T HE TERMINAL (see section 12.9.5.2.1). THE STANDARD 
c *** PROVIDES NO SUCH CAPABILITY. 

read (unit=*, fmt='(a60)') REQBUF 
end 

subroutine CHKRQS (REQBUF, REQST, P1IDNT, P2IDNT) 
c Performs syntactic check on request in buffer. 

integer MAXPRS, NAMLEN, IDLEN, BUFLEN, 

1 MSGLEN, MAXNBR, MAXGVN 

parameter (MAXPRS = 300, NAMLEN = 20, IDLEN = 3, BUFLEN = 60, 

1 MSGLEN « 40, MAXNBR = 20, MAXGVN =3) 

character NULL ID* (IDLEN) 
parameter (NULLID = '000') 

character REQ0K*10, REQSTP*4 

parameter (REQ0K = 'Request OK', REQSTP - 'stop') 

character REQBUF* (BUFLEN), REQST*(MSGLEN) 

character* (NAMLEN) P1IDNT, P2IDNT, LTRIM 
integer SEMLOC 

SEMLOC = INDEX (REQBUF,';') 

P2IDNT = REQBUF (SEMLOC+1 : BUFLEN) 

c set REQST, based on results of scan of REQBUF, and 
c fill in P1IDNT and P2IDNT. 
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if (SEMLOC .eq. .or. INDEX (P2IDNT, ";') .ne. 0) then 

REQST = 'must be exactly one semicolon." 
else 

if (SEMLOC ,eq. 1) then 

P1IDNT = ' " 
else 

P1IDNT = REQBUF (1 : SEMLOC -1) 
end if 
if (P1IDNT .eq. ' ") then 

REQST = "null field preceding semicolon." 
else if (P2IDNT .eq. " ') then 

REQST = "null field following semicolon." 
else 

REQST = REQOK 
P1IDNT = LTRIM (P1IDNT) 
P2IDNT = LTRIM (P2IDNT) 
end if 
end if 
end 

character* (*) function LTRIM (STRING) 
c LTRIM deletes leading spaces and returns the resulting value. 

character* (*) STRING 

do 100 ITEMP = 1, len( STRING) 

if (STRING (ITEMP : ITEMP) .ne. ' ") goto 101 

100 continue 

101 continue 

LTRIM = STRING (ITEMP : len(STRING)) 
end 

subroutine SEEKPR (P1IDNT, P2IDNT, P1DEX, P2DEX, 
1 P1FND, P2FND) 

c SEEKPR scans through the PERSON array, looking for the two 
c requested PERSONS. Match may be by NAME or unique IDENT-number 

integer MAXPRS, NAMLEN, IDLEN, BUFLEN, 

1 MS GLEN, MAXNBR, MA.XGVN 

parameter (MAXPRS = 300, NAMLEN = 20, IDLEN = 3, BUFLEN = 60, 

1 MSGLEN = 40, MXNBR = 20, MAXGVN = 3) 

character NULLID*( IDLEN) 
parameter (NULLID - "000") 

character* (NAMLEN) P1IDNT, P2IDNT 

integer P1DEX, P2DEX, P1FND, P2FND 

integer CURRNT 
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c These common blocks hold the PERSON array, which is global to 
c the entire program. 

common /PERNUM/ NBRCNT, NBRDEX, NBREDG, DSTSRC, PATHPR, 
1 EDGPRD, RCHST, DSCGEN, NUMPER 

common /PERCHR/ NAME, IDENT, GENDER, RELID, DSCID 

c The following data items constitute the PERSON array, which 

c is the central repository of information about inter-relationships 

c static information - filled from PEOPLE file 

character* (NAMLEN) NAME (MAXPRS) 

character* (IDLEN) IDENT (MAXPRS) 

character*l GENDER (MAXPRS) 

c IDENTs of immediate relatives - father, mother, spouse 

character* (IDLEN) RELID (MAXPRS, MAXGVN) 
c pointers to immediate neighbors in graph 

integer NBRCNT (MAXPRS) 

integer NBRDEX (MAXPRS, MAXNBR) 

integer NBREDG (MAXPRS, MAXNBR) 

c data used when traversing graph to resolve user request: 

real DSTSRC (MAXPRS) 

integer PATHPR (MAXPRS) 

integer EDGPRD (MAXPRS) 

integer RCHST (MAXPRS) 

c data used to compute common genetic material 

character* (IDLEN) DSCID (MAXPRS) 

real DSCGEN (MAXPRS) 

c NUMPER keeps track of the actual number of persons 
integer NUMPER 

c *** end of declarations for common data *** 


100 


P1DEX = 


P2DEX = 


P1FND = 


P2FND = 


do 100 CURRNT = 1, NUMPER 


allow identification by name or 

number . 

if (P1IDNT .eq. IDENT (CURRNT) 

.or. 

P1IDNT .eq. NAME (CURRNT)) 

then 

P1FND = P1FND + 1 


P1DEX = CURRNT 


end if 


if (P2IDNT .eq. IDENT (CURRNT) 

.or. 

P2IDNT .eq. NAME (CURRNT)) 

then 

P2FND = P2FND + 1 


P2DEX = CURRNT 


end if 


continue 


end 
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subroutine FINDRL (TRGDEX, SRCDEX) 

c Finds shortest path (if any) between two PERSONS and 

c determines their relationship based on immediate relations 

c traversed in path. PERSON array simulates a directed graph, 

c and algorithm finds shortest path, based on following 

c weights: PARENT-CHILD edge - 1.0 
c SPOUSE-SPOUSE edge -1.8 

integer TRGDEX, SRCDEX 

integer MAXPRS, NAMLEN, IDLEN, BUFLEN, 
1 MSGLEN, MAXNBR, MAXGVN 

parameter (MAXPRS * 300, NAMLEN = 20, IDLEN - 3, BUFLEN = 60, 
1 MSGLEN - 40, MAXNBR - 20, MAXGVN =» 3) 

character NULLID*( IDLEN) 
parameter (NULLID = '000') 

c A node in the graph (* PERSON) has either already been reached, 
c is immediately adjacent to those reached, or farther away. 

integer REACHD, NEARBY, N0SEEN 

parameter (REACHD - 1, NEARBY - 2, N0SEEN =3) 

c These common blocks hold the PERSON array, which is global to 
c the entire program. 

common /PERNUM/ NBRCNT, NBRDEX, NBREDG, DSTSRC, PATHPR, 

1 EDGPRD, RCHST, DSCGEN, NUMPER 

common /PERCHR/ NAME, IDENT, GENDER, RELID, DSCID 

c The following data items constitute the PERSON array, which 

c is the central repository of information about inter-relationships 

c static information - filled from PEOPLE file 

character* (NAMLEN) NAME (MAXPRS) 

character* (IDLEN) IDENT (MAXPRS) 

character*! GENDER (MAXPRS) 

c IDENTs of immediate relatives - father, mother, spouse 

character* (IDLEN) RELID (MAXPRS, MAXGVN) 
c pointers to immediate neighbors in graph 

integer NBRCNT (MAXPRS) 

integer NBRDEX (MAXPRS, MAXNBR) 

integer NBREDG (MAXPRS, MAXNBR) 

c data used when traversing graph to resolve user request: 

real DSTSRC (MAXPRS) 

integer PATHPR (MAXPRS) 

integer EDGPRD (MAXPRS) 

integer RCHST (MAXPRS) 

c data used to compute common genetic material 

character*(IDLEN) DSCID (MAXPRS) 

real DSCGEN (MAXPRS) 

c NUMPER keeps track of the actual number of persons 

integer NUMPER 

c *** end of declarations for common data *** 
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integer 

PERDEX, 

THSNOD, ADJNOD, 

1 

BSTDEX, 

IASTNR, NEARND (MAXPRS) 

integer 

THSEDG, 

THSNBR 

integer 

RELSHP 


real 

MINDIS 


integer 

SRCHNG, 

SUCCES, FAILED 

parameter 

(SRCHNG « 

* 1, SUCCES -■ 2, FAILED 


3 > 

integer SRCHST 

c begin execution of FINDRL 

c initialize PERSON-array for processing - 
c mark all nodes as not seen 

do 100 PERDEX = 1, NUMPER 
RCHST (PERDEX) = NOSEEN 
100 continue 

THSNOD - SRCDEX 
c mark source node as reached 

RCHST (THSNOD) = REACHD 

DSTSRC (THSNOD) - 0.0 
c no NEARBY nodes exist yet 

LASTNR =0 

if (THSNOD .eq. TRGDEX) then 
SRCHST - SUCCES 

else 

SRCHST - SRCHNG 

end if 
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c Loop keeps processing closest-to-source, unreached node 
c until target reached, or no more connected nodes. 

200 continue 

if (SRCHST .ne. SRCHNG) goto 201 
c Process all nodes adjacent to THSNOD 
do 210 THSNBR = 1, NBRCNT (THSNOD) 

call PR0CAD (THSNOD, NBRDEX (THSNOD, THSNBR), 
1 NBREDG (THSNOD, THSNBR), NEARND, IASTNR) 

210 continue 

c All nodes adjacent to THSNOD are set. Now search for 
c shortest-distance unreached (but NEARBY) node to process next 
if (LASTNR .eq. 0) then 

SRCHST = FAILED 
else 
c determine next node to process 

MINDIS = 1.0E+18 
do 220 PERDEX = 1, LASTNR 

if (DSTSRC (NEARND (PERDEX)) .It. MINDIS) then 
BSTDEX = PERDEX 

MINDIS = DSTSRC (NEARND (PERDEX)) 
end if 
220 continue 
c establish new THSNOD 

THSNOD = NEARND (BSTDEX) 
c change THSNOD from being NEARBY to reached 

RCHST (THSNOD) = REACHD 
c remove THSNOD from NEARBY list 

NEARND (BSTDEX) = NEARND (LASTNR) 
LASTNR = LASTNR - 1 

if (THSNOD .eq. TRGDEX) SRCHST = SUCCES 
end if 
goto 200 

201 continue 

c Shortest path between PERSONS now established. Next task is 
c to translate path to English description of relationship, 
if (SRCHST .eq. FAILED) then 

write (unit=*, fmt=9001) NAME (TRGDEX), NAME (SRCDEX) 
9001 format (a22, ' is not related to ', a20) 

else 
c success - parse path to find and display relationship 

call RESOLV (SRCDEX, TRGDEX) 
c compute proportion of common genetic material 
call CMPTGN (SRCDEX, TRGDEX) 
end if 
end 
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c procedures under FINDRL 

subroutine PROCAD (BASNOD, NXTNOD, NBEDGE, NEARND, LASTNR) 

c NXTNOD is adjacent to last-reached node (= BASNOD) . 

c If NXTNOD already reached, do nothing, 

c If previously seen, check whether path thru BASNOD is 

c shorter than current path to NXTNOD, and if so re-link 

c next to base . 

c If not previously seen, link next to base node. 

integer NXTNOD, BASNOD, NEARND (*), LASTNR 
integer NBEDGE 

integer MAXPRS, NAMLEN, IDLEN, BUFLEN, 

1 MS GLEN, MAXNBR, MAXGVN 

parameter (MAXPRS = 300, NAMLEN = 20, IDLEN = 3, BUFLEN = 60, 

1 MSGLEN = 40, MAXNBR = 20, MAXGVN = 3) 

character NULLID*( IDLEN) 
parameter (NULLID = '000') 

c A node in the graph (= PERSON) has either already been reached, 
c is immediately adjacent to those reached, or farther away. 

integer REACHD, NEARBY, N0SEEN 

parameter (REACHD - 1, NEARBY - 2, NOSEEN =3) 

c These common blocks hold the PERSON array, which is global to 
c the entire program. 

common /PERNUM/ NBRCNT, NBRDEX, NBREDG, DSTSRC, PATHPR, 
1 EDGPRD, RCHST, DSCGEN, NUMPER 

common /PERCHR/ NAME, IDENT, GENDER, RELID, DSCID 

c The following data items constitute the PERSON array, which 

c is the central repository of information about inter-relationships 

c static information - filled from PEOPLE file 

character* (NAMLEN) NAME (MAXPRS) 

character* (IDLEN) IDENT (MAXPRS) 

character*! GENDER (MAXPRS) 

c IDENTs of immediate relatives - father, mother, spouse 

character* (IDLEN) RELID (MAXPRS, MAXGVN) 
c pointers to immediate neighbors in graph 

integer NBRCNT (MAXPRS ) 

integer NBRDEX (MAXPRS, MAXNBR) 

integer NBREDG (MAXPRS, MAXNBR) 

c data used when traversing graph to resolve user request: 

real DSTSRC (MAXPRS) 

integer PATHPR (MAXPRS) 

integer EDGPRD (MAXPRS) 

integer RCHST (MAXPRS) 

c data used to compute common genetic material 

character* (IDLEN) DSCID (MAXPRS) 

real DSCGEN (MAXPRS) 
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c NUMPER keeps track of the actual number of persons 
integer NUMPER 

c *** end of declarations for common data *** 


real 


WGHTEG, DSTBAS 


c begin execution of PROCAD 

if (RCHST (NXTNOD) .ne. REACHD) then 
if (NBEDGE .eq. SPOUSE) then 

WGHTEG =1.8 
else 

WGHTEG -1.0 
end if 

DSTBAS = WGHTEG + DSTSRC (BASNOD) 
if (RCHST (NXTNOD) .eq. NOSEEN) then 
c change status of THSNOD from not-seen to NEARBY 

RCHST (NXTNOD) = NEARBY 
LASTNR = LASTNR + 1 
NEARND (LASTNR) = NXTNOD 
c link next to base by re-setting its predecessor index to 

c point to base, note type of edge, and re-set distance 

c as it is through base node. 

DSTSRC (NXTNOD) - DSTBAS 
PATHPR (NXTNOD) = BASNOD 
EDGPRD (NXTNOD) = NBEDGE 
else 
c RCHST is NEARBY 

if (DSTBAS .It. DSTSRC (NXTNOD)) then 
c link next to base by re-setting its predecessor index to 

c point to base, note type of edge, and re-set distance 

c as it is through base node. 

DSTSRC (NXTNOD) = DSTBAS 
PATHPR (NXTNOD) = BASNOD 
EDGPRD (NXTNOD) = NBEDGE 
end if 
end if 
end if 
end 
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subroutine RESOLV (SRCDEX, TRGDEX) 
c RESOLV condenses the shortest path to a series of 
c relationships for which there are English descriptions. 

integer SRCDEX, TRGDEX 

c Establish global constants 

integer MAXPRS, NAMLEN, IDLEN, BUFLEN, 

1 MS GLEN, MAXNBR, MAXGVN 

parameter (MAXPRS = 300, NAMLEN = 20, IDLEN - 3, BUFLEN - 60, 

1 MSGLEN = 40, MAXNBR = 20, MAXGVN = 3) 

character NULLID*( IDLEN) 
parameter (NULLID - '000') 

character MALE*1, FEMALE*1 
parameter (MALE = 'M', FEMALE = 'F') 

integer PARENT, CHILD, SPOUSE, SIBLNG, 

1 UNCLE, NEPHEW, COUSIN, NULLRL 

parameter (PARENT = 1, CHILD = 2, SPOUSE = 3, SIBLNG = 4, 

1 UNCLE - 5, NEPHEW = 6, COUSIN = 7, NULLRL = 8) 

c sibling proximity can have three values 

integer STEP, HALF, FULL 

parameter (STEP - 1, HALF = 2, FULL =3) 

c These common blocks hold the PERSON array, which is global to 
c the entire program. 

common /PERNUM/ NBRCNT, NBRDEX, NBREDG, DSTSRC, PATHPR, 
1 EDGPRD, RCHST, DSCGEN, NUMPER 

common /PERCHR/ NAME, IDENT, GENDER, RELID, DSCID 
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c The following data items constitute the PERSON array, which 

c is the central repository of information about inter-relationships 

c static information - filled from PEOPLE file 

character* (NAMLEN) NAME (MAXPRS) 

character* (IDLEN) IDENT (MAXPRS) 

character*! GENDER (MAXPRS) 

c IDENTs of immediate relatives - father, mother, spouse 

character* (IDLEN) RELID (MAXPRS, MAXGVN) 
c pointers to immediate neighbors in graph 

integer NBRCNT (MAXPRS) 

integer NBRDEX (MAXPRS, MAXNBR) 

integer NBREDG (MAXPRS, MAXNBR) 

c data used when traversing graph to resolve user request: 

real DSTSRC (MAXPRS) 

integer PATHPR (MAXPRS) 

integer EDGPRD (MAXPRS) 

integer RCHST (MAXPRS) 

c data used to compute common genetic material 

character* (IDLEN) DSCID (MAXPRS) 

real DSC GEN (MAXPRS) 

c NUMPER keeps track of the actual number of persons 
integer NUMPER 

c *** en d f declarations for common data *** 

c these variables are used to generate key-person data 
integer GENCNT, THSCUZ 

integer THSPRX 

c these variables are used to condense the path 

common /KEYPER/ RELNXT, PERDEX, GENGAP, PRXMTY, CUZRNK 

c Key persons are the ones in the relationship path which remain 
c after the path is condensed. 

integer RELNXT (MAXPRS) 

integer PERDEX (MAXPRS) 

integer GENGAP (MAXPRS) 

integer PRXMTY (MAXPRS) 

integer CUZRNK (MAXPRS) 

integer KEYREL, LATREL, PRIREL, NXTPRI 

integer KEYDEX, LATDEX, PRIDEX, THSNOD 

integer GAP1, GAP2 

logical SEEKMR, FULSIB 
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c begin execution of RESOLV 
write (unit=*, 

1 fmt='(" Shortest path between identified persons: ")') 
c Display path and initialize key person arrays from path elements . 
THSNOD = TRGDEX 
do 100 KEYDEX = 1, MAXPRS 

if (THSNOD .eq. SRCDEX) goto 101 

PERDEX (KEYDEX) = THSNOD 

PRXMTY (KEYDEX) = FULL 

RELNXT (KEYDEX) = EDGPRD (THSNOD) 

if (EDGPRD (THSNOD) .eq. SPOUSE) then 

write (unit=*, fmt='(a22, " is spouse of")') NAME (THSNOD) 
GENGAP (KEYDEX) = 
else 

GENGAP (KEYDEX) = 1 

if (EDGPRD (THSNOD) .eq. PARENT) then 

write (unit=*, fmt='(a22, " is parent of")') 
1 NAME (THSNOD) 

else 

write (unit=*, fmt='(a22, " is child of")') 
1 NAME (THSNOD) 

end if 
end if 
THSNOD = PATHPR (THSNOD) 

100 continue 

101 continue 

write (unit=*, fmt='(a22)') NAME (THSNOD) 
PERDEX (KEYDEX) = THSNOD 
RELNXT (KEYDEX) = NULLRL 
RELNXT (KEYDEX + 1) = NULLRL 
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c resolve CHILD-PARENT and CHILD-SPOUSE-PARENT relations 
c to SIBLNG relations. 

do 200 KEYDEX = 1, MAXPRS 

if (RELNXT (KEYDEX) .eq. NULLRL) goto 201 
if (RELNXT (KEYDEX) .eq. CHILD) then 
LATREL = RELNXT (KEYDEX + 1) 
if (LATREL .eq. PARENT) then 
c found either full or half SIBLNGs 

if (FULSIB (PERDEX (KEYDEX), PERDEX (KEYDEX +2))) then 

PRXMTY (KEYDEX) = FULL 
else 

PRXMTY (KEYDEX) - HALF 
end if 

GENGAP (KEYDEX) = 
RELNXT (KEYDEX) = SIBLNG 
call CONDNS (KEYDEX, 1) 
else if (LATREL .eq. SPOUSE .and. 
1 RELNXT (KEYDEX +2) .eq. PARENT) then 

c found step-SIBLNGs 

GENGAP (KEYDEX) = 
PRXMTY (KEYDEX) = STEP 
RELNXT (KEYDEX) - SIBLNG 
call CONDNS (KEYDEX, 2) 
end if 
end if 

200 continue 

201 continue 

c resolve CHILD-CHILD-. . . and PARENT-PARENT-. . . relations to 
c direct descendant or ancestor relations, 
do 300 KEYDEX = 1, MAXPRS 

if (RELNXT (KEYDEX) .eq. NULLRL) goto 301 
if (RELNXT (KEYDEX) .eq. CHILD .or. 
1 RELNXT (KEYDEX) .eq. PARENT) then 
do 310 LATDEX = KEYDEX + 1, MAXPRS 

if (RELNXT (LATDEX) .ne. RELNXT (KEYDEX)) goto 311 

310 continue 

311 continue 

GENCNT = LATDEX - KEYDEX 
if (GENCNT .gt. 1) then 
c compress generations 

GENGAP (KEYDEX) = GENCNT 
call CONDNS (KEYDEX, GENCNT - 1) 
end if 
end if 

300 continue 

301 continue 
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c resolve CHILD-SIBLNG-PARENT to COUSIN, 

c CHILD-SIBLNG to NEPHEW, 

c SIBLNG-PARENT to UNCLE. 

do 400 KEYDEX = 1, MAXPRS 

if (RELNXT (KEYDEX) .eq. NULLRL) goto 401 
IATREL - RELNXT (KEYDEX +1) 

if (RELNXT (KEYDEX) .eq. CHILD .and. LATREL .eq. SIBLNG) then 
c found COUSIN or NEPHEW 

PRXMTY (KEYDEX) = PRXMTY (KEYDEX + 1) 
if (RELNXT (KEYDEX + 2) .eq. PARENT) then 
c found COUSIN 

GAP1 = GENGAP (KEYDEX) 
GAP2 - GENGAP (KEYDEX + 2) 
GENGAP (KEYDEX) = abs (GAPl - GAP2) 
CUZRNK (KEYDEX) = min (GAPl, GAP2) 
RELNXT (KEYDEX) - COUSIN 
call CONDNS (KEYDEX, 2) 
else 
c found NEPHEW 

RELNXT (KEYDEX) = NEPHEW 
call CONDNS (KEYDEX, 1) 
end if 
else 

if (RELNXT (KEYDEX) .eq. SIBLNG .and. 
1 LATREL .eq. PARENT) then 

c found UNCLE 

GENGAP (KEYDEX) = GENGAP (KEYDEX + 1) 
RELNXT (KEYDEX) = UNCLE 
call CONDNS (KEYDEX, 1) 
end if 
end if 

400 continue 

401 continue 
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c Loop below will pick out valid adjacent strings of elements 

c to be displayed. KEYDEX points to first element, 

c LATDEX to last element, and PRIDEX to the 

c element which determines the primary English word to be used. 

c Associativity of adjacent elements in condensed table 

c is based on English usage. 


Condensed path:")') 
NULLRL) goto 501 


KEYDEX = 1 

write (unit=*, fmt='(" 
500 continue 

if (RELNXT (KEYDEX) .eq. 
KEYREL = RELNXT (KEYDEX) 
LATDEX = KEYDEX 
PRIDEX = KEYDEX 

if (RELNXT (KEYDEX + 1) .ne. NULLRL) then 
c seek multi-element combination 

SEEKMR = .true, 
if (KEYREL .eq. SPOUSE) then 
LATDEX = LATDEX + 1 
PRIDEX = LATDEX 
c Nothing can follow SPOUSE-SIBLNG or SPOUSE-COUSIN 

SEEKMR = .not. (RELNXT (LATDEX) .eq. SIBLNG .or. 
1 RELNXT (LATDEX) .eq. COUSIN) 

end if 


c PRIDEX is now correctly set. Next if-statement 

c determines if a following SPOUSE relation should be 

c appended to this combination or left for the next 

c combination. 

if (SEEKMR .and. RELNXT (PRIDEX + 1) .eq. SPOUSE) then 
c Only a SPOUSE can follow a Primary, 

c Check primary preceding and following SPOUSE. 

PRIREL = RELNXT (PRIDEX) 
NXTPRI = RELNXT (PRIDEX +2) 
if ((NXTPRI .eq. NEPHEW .or. 
COUSIN .or. 
NULLRL) 
eq. NEPHEW) 

.eq. SIBLNG .or. PRIREL .eq. PARENT) 
NXTPRI .ne. UNCLE )) then 
c append following SPOUSE with this combination. 

IATDEX - LATDEX + 1 
end if 
end if 
end if 
c end multi-element combination 

call SHOWRE (KEYDEX, LATDEX, PRIDEX) 
KEYDEX = LATDEX + 1 
goto 500 
501 continue 

write (unit=*, fmt='(a22)') NAME (PERDEX (KEYDEX)) 
end 
c end of RES0LV 


1 

NXTPRI .eq. 

2 

NXTPRI .eq. 

3 

.or. (PRIREL 

4 

.or. ((PRIREL 

5 

.and. '. 
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logical function FULSIB (INDEX1, INDEX2) 

Determines whether two PERSONS are full siblings, i.e. 

have the same two parents . 

integer INDEX1, INDEX2 


integer MAXPRS, NAMLEN, IDLEN, BUFLEN, 
1 MSGLEN, MAXNBR, MAXGVN 

parameter (MAXPRS = 300, NAMLEN - 20, IDLEN 
1 MSGLEN - 40, MAXNBR « 20, MAXGVN 


3, BUFLEN = 60, 
3) 


character NULLID*( IDLEN) 
parameter (NULLID = '000') 

integer FATHID, M0THID, SP0UID 

parameter (FATHID = 1, MOTHID = 2, SPOUID = 3) 

c These common blocks hold the PERSON array, which is global to 
c the entire program. 

common /PERNUM/ NBRCNT, NBRDEX, NBREDG, DSTSRC, PATHPR, 
1 EDGPRD, RCHST, DSCGEN, NUMPER 

common /PERCHR/ NAME, IDENT, GENDER, RELID, DSCID 

c The following data items constitute the PERSON array, which 

c is the central repository of information about inter-relationships 

c static information - filled from PEOPLE file 

character* (NAMLEN) NAME (MAXPRS) 

character* (IDLEN) IDENT (MAXPRS) 

character*l GENDER (MAXPRS) 

c IDENTs of immediate relatives - father, mother, spouse 

character* (IDLEN) RELID (MAXPRS, MAXGVN) 
c pointers to immediate neighbors in graph 

integer NBRCNT (MAXPRS) 

integer NBRDEX (MAXPRS, MAXNBR) 

integer NBREDG (MAXPRS, MAXNBR) 

c data used when traversing graph to resolve user request: 

real DSTSRC (MAXPRS) 

integer PATHPR (MAXPRS) 

integer EDGPRD (MAXPRS) 

integer RCHST (MAXPRS) 

c data used to compute common genetic material 

character* (IDLEN) DSCID (MAXPRS) 

real DSCGEN (MAXPRS) 

c NUMPER keeps track of the actual number of persons 

integer NUMPER 

c *** end of declarations for common data *** 

FULSIB - 

1 RELID (INDEX1, FATHID) .ne. NULLID .and. 

2 RELID (INDEX1, MOTHID) .ne. NULLID .and. 

3 RELID (INDEX1, FATHID) .eq. RELID (INDEX2, FATHID) .and. 

4 RELID (INDEX1, MOTHID) .eq. RELID (INDEX2, MOTHID) 
end 
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subroutine CONDNS (ATDEX, GAPSIZ) 
c CONDNS condenses superfluous entries from the 
c key person arrays, starting at ATDEX. 

integer MAXPRS, NAMLEN, IDLEN, BUFLEN, 
1 MSGLEN, MAXNBR, MAXGVN 

parameter (MAXPRS = 300, NAMLEN = 20, IDLEN - 3, BUFLEN = 60, 
1 MSGLEN = 40, MAXNBR = 20, MAXGVN = 3) 

character NULLID* (IDLEN) 
parameter (NULLID = '000') 

integer PARENT, CHILD, SPOUSE, SIBLNG, 

1 UNCLE, NEPHEW, COUSIN, NULLRL 

parameter (PARENT - 1, CHILD - 2, SPOUSE - 3, SIBLNG = 4, 

1 UNCLE = 5, NEPHEW = 6, COUSIN = 7, NULLRL = 8) 

common /KEYPER/ RELNXT, PERDEX, GENGAP, PRXMTY, CUZRNK 

c Key persons are the ones in the relationship path which remain 
c after the path is condensed. 

integer RELNXT (MAXPRS) 

integer PERDEX (MAXPRS) 

integer GENGAP (MAXPRS) 

integer PRXMTY (MAXPRS) 

integer CUZRNK (MAXPRS) 

integer ATDEX, GAPSIZ, SENDEX, RCVDEX 

RCVDEX = ATDEX 
100 continue 

RCVDEX = RCVDEX + 1 
SENDEX = RCVDEX + GAPSIZ 
RELNXT (RCVDEX) = RELNXT (SENDEX) 
PERDEX (RCVDEX) = PERDEX (SENDEX) 
GENGAP (RCVDEX) = GENGAP (SENDEX) 
PRXMTY (RCVDEX) = PRXMTY (SENDEX) 
CUZRNK (RCVDEX) = CUZRNK (SENDEX) 
if (RELNXT (SENDEX) .ne. NULLRL) goto 100 
end 
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c procedures under RESOLV 

subroutine SHOWRE (FSTDEX, LSTDEX, PRIDEX) 
c SHOWRE takes 1, 2, or 3 adjacent elements in the 
c condensed table and generates the English description of 
c the relation between the first and last + 1 elements. 

c Establish global constants 

integer MAXPRS, NAMLEN, IDLEN, BUFLEN, 

1 MSGLEN, MAXNBR, MAXGVN 

parameter (MAXPRS = 300, NAMLEN = 20, IDLEN = 3, BUFLEN = 60, 

1 MSGLEN = 40, MAXNBR = 20, MAXGVN = 3) 

character NULLID*( IDLEN) 
parameter (NULLID = '000') 

character MALE*1, FEMALE*1 
parameter (MALE = 'M' , FEMALE = 'F') 

integer PARENT, CHILD, SPOUSE, SIBLNG, 

1 UNCLE, NEPHEW, COUSIN, NULLRL 

parameter (PARENT - 1, CHILD = 2, SPOUSE = 3, SIBLNG = 4, 

1 UNCLE = 5, NEPHEW = 6, COUSIN = 7, NULLRL = 8) 

c sibling proximity can have three values 

integer STEP, HALF, FULL 

parameter (STEP = 1, HALF = 2, FULL = 3) 

c These common blocks hold the PERSON array, which is global to 
c the entire program. 

common /PERNUM/ NBRCNT, NBRDEX, NBREDG, DSTSRC, PATHPR, 

1 EDGPRD, RCHST, DSCGEN, NUMPER 

common /PERCHR/ NAME, IDENT, GENDER, RELID, DSCID 
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c The following data items constitute the PERSON array, which 

c is the central repository of information about inter-relationships 

c static information - filled from PEOPLE file 

character* (NAMLEN) NAME (MAXPRS) 

character* (IDLEN) IDENT (MAXPRS) 

character *1 GENDER (MAXPRS) 

c IDENTs of immediate relatives - father, mother, spouse 

character* (IDLEN) RELID (MAXPRS, MAXGVN) 
c pointers to immediate neighbors in graph 

integer NBRCNT (MAXPRS) 

integer NBRDEX (MAXPRS, MAXNBR) 

integer NBREDG (MAXPRS, MAXNBR) 

c data used when traversing graph to resolve user request: 

real DSTSRC (MAXPRS) 

integer PATHPR (MAXPRS) 

integer EDGPRD (MAXPRS) 

integer RCHST (MAXPRS) 

c data used to compute common genetic material 

character* (IDLEN) DSCID (MAXPRS) 

real DSC GEN (MAXPRS) 

c NUMPER keeps track of the actual number of persons 
integer NUMPER 

common /KEYPER/ RELNXT, PERDEX, GENGAP, PRXMTY, CUZRNK 


c 

Key persons are tl 

le ones in the relations! 

c 

after the path is 

condensed. 


integer 

RELNXT (MAXPRS) 


integer 

PERDEX (MAXPRS) 


integer 

GENGAP (MAXPRS) 


integer 

PRXMTY (MAXPRS) 


integer 

CUZRNK (MAXPRS) 

c 

*** end of declarations for common data *** 


logical 

INLAW 


integer 

THSPRX, THSGAP, THSCUZ 


character 

TW0DIG*2 


integer 

SUFPTR 


character 

SUFCHR*12 


integer 

FSTDEX, LSTDEX, PRIDEX 


integer 

FSTREL, LSTREL, PRIREL 


character*75 

OUTBUF 


integer 

OUTPTR 
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c begin execution of SHOWRE 

FSTREL - RELNXT (FSTDEX) 
LSTREL = RELNXT (LSTDEX) 
PRIREL = RELNXT (PRIDEX) 

c set THSPRX 

if ((PRIREL .eq. PARENT .and. FSTREL .eq. SPOUSE) .or. 
1 (PRIREL .eq. CHILD .and. LSTREL .eq. SPOUSE)) then 
THSPRX = STEP 
else 

if (PRIREL .eq. SIBLNG .or. PRIREL .eq. UNCLE .or. 
1 PRIREL .eq. NEPHEW .or. PRIREL .eq. COUSIN) then 
THSPRX = PRXMTY (PRIDEX) 
else 

THSPRX = FULL 
end if 
end if 

c set THSGAP 

if (PRIREL .eq. PARENT .or. PRIREL .eq. CHILD .or. 

1 PRIREL .eq. UNCLE .or. PRIREL .eq. NEPHEW .or. 

2 PRIREL .eq. COUSIN) then 
THSGAP = GENGAP (PRIDEX) 

else 

THSGAP = 
end if 

c set INLAW 

if (FSTREL .eq. SPOUSE .and. 

1 (PRIREL .eq. SIBLNG .or. PRIREL .eq. CHILD .or. 

2 PRIREL .eq. NEPHEW .or. PRIREL .eq. COUSIN)) then 
INLAW = .true. 

else 

if (LSTREL .eq. SPOUSE .and. 

1 (PRIREL .eq. SIBLNG .or. PRIREL .eq. PARENT .or. 

2 PRIREL .eq. UNCLE .or. PRIREL .eq. COUSIN)) then 
INLAW = .true. 

else 

INLAW = .false, 
end if 
end if 

c set THSCUZ 

if (PRIREL .eq. COUSIN) then 

THSCUZ = CUZRNK (PRIDEX) 
else 

THSCUZ = 
end if 
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parameters are set - now generate display. 

OUTBUF = NAME (PERDEX (FSTDEX)) // ' is ' 
OUTPTR - NAMLEN + 5 

if (PRIREL .eq. PARENT .or. PRIREL .eq. CHILD .or. 
1 PRIREL .eq. UNCLE .or. PRIREL .eq. NEPHEW) then 
display generation-qualifier 
if (THSGAP .ge. 3) then 

call APPEND (OUTBUF, OUTPTR, 'great') 
if (THSGAP .gt. 3) then 

write (unit=TWODIG, fmt='(i2)') THSGAP - 2 
call APPEND (OUTBUF, OUTPTR, '*' // TWODIG) 
end if 

call APPEND (OUTBUF, OUTPTR, '-') 
end if 
if (THSGAP .ge. 2) then 

call APPEND (OUTBUF, OUTPTR, 'grand-') 
end if 
else 

if (PRIREL .eq. COUSIN .and. THSCUZ .gt. 1) then 
display cousin-degree 
write (unit=TWODlG, fmt»'(i2)') THSCUZ 
call APPEND (OUTBUF, OUTPTR, TWODIG) 
SUFPTR - mod (THSCUZ, 10) 
if (SUFPTR .gt. 3) SUFPTR - 
SUFPTR - 3 * SUFPTR + 1 
SUFCHR - 'th st nd rd ' 

call APPEND (OUTBUF, OUTPTR, SUFCHR (SUFPTR : SUFPTR +2)) 
end if 
end if 

if (THSPRX .eq. STEP) then 

call APPEND (OUTBUF, OUTPTR, 'step-') 
else 

if (THSPRX .eq. HALF) then 

call APPEND (OUTBUF, OUTPTR, 'half-') 

end if 
end if 
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if (GENDER (PERDEX (FSTDEX)) .eq. MALE) then 

goto (201,202,203,204,205,206,297,298), PRIREL 

201 continue 

call APPEND (OUTBUF, OUTPTR, 'father') 
goto 300 

202 continue 

call APPEND (OUTBUF, OUTPTR, 'son') 
goto 300 

203 continue 

call APPEND (OUTBUF, OUTPTR, 'husband') 
goto 300 

204 continue 

call APPEND (OUTBUF, OUTPTR, 'brother') 
goto 300 

205 continue 

call APPEND (OUTBUF, OUTPTR, 'uncle') 
goto 300 

206 continue 

call APPEND (OUTBUF, OUTPTR, 'nephew') 
goto 300 
else 
c gender is FEMALE 

goto (251,252,253,254,255,256,297,298), PRIREL 

251 continue 

call APPEND (OUTBUF, OUTPTR, 'mother') 
goto 300 

252 continue 

call APPEND (OUTBUF, OUTPTR, 'daughter') 
goto 300 

253 continue 

call APPEND (OUTBUF, OUTPTR, 'wife') 
goto 300 

254 continue 

call APPEND (OUTBUF, OUTPTR, 'sister') 
goto 300 

255 continue 

call APPEND (OUTBUF, OUTPTR, 'aunt') 
goto 300 

256 continue 

call APPEND (OUTBUF, OUTPTR, 'niece') 
goto 300 
end if 

297 continue 

call APPEND (OUTBUF, OUTPTR, 'cousin') 
goto 300 

298 continue 

call APPEND (OUTBUF, OUTPTR, 'null') 
goto 300 
300 continue 
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if (INLAW) call APPEND (OUTBUF, OUTPTR, '-in-law') 

if (PRIREL .eq. COUSIN .and. THSGAP .gt. 0) then 
if (THSGAP .gt. 1) then 

write (unit=TWODIG, fmt='(i2)') THSGAP 

call APPEND (OUTBUF, OUTPTR, ' '//TWODIG//' times removed') 
else 

call APPEND (OUTBUF, OUTPTR, ' once removed') 
end if 
end if 

call APPEND (OUTBUF, OUTPTR, 'of') 
write (unit=*, fmt='(a77)') OUTBUF 
end 

subroutine APPEND (STRING, PTR, ADDEND) 
c APPEND appends the contents of ADDEND to STRING in the position 
c indicated by PTR, and increments PTR 

character STRING*(*), ADDEND*(*) 
integer PTR, ADDLEN 

ADDLEN = len (ADDEND) 

STRING (PTR : PTR + ADDLEN - 1 ) = ADDEND 

PTR = PTR + ADDLEN 

end 

c procedures under FINDRL 

subroutine CMPTGN (INDEX1, INDEX2) 
c CMPTGN assumes that each ancestor contributes 
c half of the genetic material to a PERSON. It finds common 
c ancestors between two PERSONS and computes the expected 
c value of the proportion of common material. 

integer INDEX1, INDEX2 

integer MAXPRS, NAMLEN, IDLEN, BUFLEN, 
1 MSGLEN, MAXNBR, MAXGVN 

parameter (MAXPRS = 300, NAMLEN = 20, IDLEN = 3, BUFLEN = 60, 
1 MSGLEN = 40, MAXNBR = 20, MAXGVN = 3) 

character NULLID*( IDLEN) 
parameter (NULLID - '000') 

c These common blocks hold the PERSON array, which is global to 
2 the entire program. 

common /PERNUM/ NBRCNT, NBRDEX, NBREDG, DSTSRC, PATHPR, 
1 EDGPRD, RCHST, DSCGEN, NUMPER 

common /PERCHR/ NAME, IDENT, GENDER, RELID, DSCID 
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c The following data items constitute the PERSON array, which 

c is the central repository of information about inter-relationships 

c static information - filled from PEOPLE file 

character* (NAMLEN) NAME (MAXPRS) 

character* (IDLEN) IDENT (MAXPRS) 

character*l GENDER (MAXPRS ) 

c IDENTs of immediate relatives - father, mother, spouse 

character* (IDLEN) RELID (MAXPRS, MAXGVN) 
c pointers to immediate neighbors in graph 

integer NBRCNT (MAXPRS) 

integer NBRDEX (MAXPRS, MAXNBR) 

integer NBREDG (MAXPRS, MAXNBR) 

c data used when traversing graph to resolve user request: 

real DSTSRC (MAXPRS) 

integer PATHPR (MAXPRS) 

integer EDGPRD (MAXPRS ) 

integer RCHST (MAXPRS) 

c data used to compute common genetic material 

character* (IDLEN) DSC ID (MAXPRS) 

real DSCGEN (MAXPRS) 

c NUMPER keeps track of the actual number of persons 
integer NUMPER 

c STACK is common to the routines which calculate genetic overlap, 
c It is used to implement recursive traversal of the ancestor trees. 

integer STKSIZ 
parameter (STKSIZ = 50) 

common /STACK/ PROPTN, CONTRB, COUNTD, PERDEX, NXTNBR, 
1 STKPTR 

real PROPTN (STKSIZ) 

real CONTRB (STKSIZ) 

real COUNTD (STKSIZ) 

integer PERDEX (STKSIZ) 

integer NXTNBR (STKSIZ) 

integer STKPTR 

c *** end of declarations for common data *** 

real COMPRP 
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c First zero out all ancestors to allow adding. This is necessary 
c because there might be two paths to an ancestor. 

STKPTR = 1 

PERDEX (STKPTR) - INDEX1 

NXTNBR (STKPTR) - 

100 continue 

call ZERPRO 

if (STKPTR .ge. 1) goto 100 

101 continue 

c now mark with shared PR0PTN 
STKPTR - 1 

PERDEX (STKPTR) = INDEX1 
NXTNBR (STKPTR) = 
PROPTN (STKPTR) =1.0 

200 continue 

call MRKPR0 (IDENT (INDEX1)) 
if (STKPTR .ge. 1) goto 200 

201 continue 

c traverse ancestor tree for INDEX2. summing overlap with 
c marked tree of INDEX1 

C0MPRP =0.0 

STKPTR = 1 

PERDEX (STKPTR) = INDEX2 

NXTNBR (STKPTR) - 

PROPTN (STKPTR) =1.0 

C0UNTD (STKPTR) =0.0 

300 continue 

call CHKCOM (C0MPRP, IDENT (INDEX1)) 
if (STKPTR .ge. 1) goto 300 

301 continue 

write (unit=*, fmt=9001) C0MPRP 
9001 formatC Proportion of common genetic material = ', lp, el2.5e2) 
end 

subroutine ZERPRO 
c ZERPRO recursively seeks out all ancestors and 
c zeros them out. 

integer MAXPRS, NAMLEN, IDLEN, BUFLEN, 

1 MSGLEN, MAXNBR, MAXGVN 

parameter (MAXPRS = 300, NAMLEN = 20, IDLEN - 3, BUFLEN = 60, 

1 MSGLEN = 40, MAXNBR = 20, MAXGVN = 3) 

character NULLID*( IDLEN) 
parameter (NULLID = '000') 

integer PARENT, CHILD, SPOUSE, SIBLNG, 

1 UNCLE, NEPHEW, COUSIN, NULLRL 

parameter (PARENT - 1, CHILD - 2, SPOUSE - 3, SIBLNG = 4, 

1 UNCLE = 5, NEPHEW = 6, COUSIN = 7, NULLRL = 8) 
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c These common blocks hold the PERSON array, which is global to 
c the entire program. 

common /PERNUM/ NBRCNT, NBRDEX, NBREDG, DSTSRC, PATHPR, 

1 EDGPRD, RCHST, DSCGEN, NUMPER 

common /PERCHR/ NAME, IDENT, GENDER, RELID, DSCID 

c The following data items constitute the PERSON array, which 

c is the central repository of information about inter-relationships. 

c static information - filled from PEOPLE file 

character* (NAMLEN) NAME (MAXPRS) 

character*(IDLEN) IDENT (MAXPRS) 

character*! GENDER (MAXPRS) 

c IDENTs of immediate relatives - father, mother, spouse 

character* (IDLEN) RELID (MAXPRS, MAXGVN) 
c pointers to immediate neighbors in graph 

integer NBRCNT (MAXPRS) 

integer NBRDEX (MAXPRS, MAXNBR) 

integer NBREDG (MAXPRS, MAXNBR) 

c data used when traversing graph to resolve user request: 

real DSTSRC (MAXPRS) 

integer PATHPR (MAXPRS) 

integer EDGPRD (MAXPRS) 

integer RCHST (MAXPRS) 

c data used to compute common genetic material 

character* (IDLEN) DSCID (MAXPRS) 

real DSCGEN (MAXPRS) 

c NUMPER keeps track of the actual number of persons 
integer NUMPER 

c STACK is common to the routines which calculate genetic overlap, 
c It is used to implement recursive traversal of the ancestor trees. 

integer STKSIZ 
parameter (STKSIZ = 50) 

common /STACK/ PROPTN, CONTRB, COUNTD, PERDEX, NXTNBR, 
1 STKPTR 

real PROPTN (STKSIZ) 


real 

CONTRB 

(STKSIZ) 

real 

COUNTD 

(STKSIZ) 

integer 

PERDEX 

(STKSIZ) 

integer 

NXTNBR 

(STKSIZ) 

integer 

STKPTR 



c *** end f declarations for common data *** 


Page 130 


integer ZERDEX, THSNBR 

ZERDEX - PERDEX (STKPTR) 

if (NXTNBR (STKPTR) .eq. 0) then 

DSC GEN (ZERDEX) =0.0 

NXTNBR (STKPTR) = 1 
end if 
do 100 THSNBR = NXTNBR (STKPTR), NBRCNT (ZERDEX) 

if (NBREDG (ZERDEX, THSNBR) .eq. PARENT) goto 101 

100 continue 

101 continue 

if (THSNBR .gt. NBRCNT (ZERDEX)) then 
c no more ancestors from this person 

STKPTR = STKPTR - 1 
else 
c set up for next ancestor 

NXTNBR (STKPTR) = THSNBR + 1 

STKPTR = STKPTR + 1 

PERDEX (STKPTR) = NBRDEX (ZERDEX, THSNBR) 

NXTNBR (STKPTR) = 
end if 
end 

subroutine MRKPR0 (MARKER) 
c MRKPRO recursively seeks out all ancestors and 
c marks them with the sender's proportion of shared 
c genetic material. This proportion is diluted by one-half 
c for each generation. 

integer MAXPRS, NAMLEN, IDLEN, BUFLEN, 

1 MSGLEN, MAXNBR, MAXGVN 

parameter (MAXPRS = 300, NAMLEN = 20, IDLEN = 3, BUFLEN - 60, 

1 MSGLEN = 40, MAXNBR = 20, MAXGVN = 3) 

character NULLID*( IDLEN) 
parameter (NULLID = '000') 

integer PARENT, CHILD, SPOUSE, SIBLNG, 

1 UNCLE, NEPHEW, COUSIN, NULLRL 

parameter (PARENT = 1, CHILD - 2, SPOUSE = 3, SIBLNG = 4, 

1 UNCLE = 5, NEPHEW = 6, COUSIN = 7, NULLRL = 8) 

c These common blocks hold the PERSON array, which is global to 
c the entire program. 

common /PERNUM/ NBRCNT, NBRDEX, NBREDG, DSTSRC, PATHPR, 
1 EDGPRD, RCHST, DSCGEN, NUMPER 

common /PERCHR/ NAME, IDENT, GENDER, RELID, DSCID 
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c The following data Items constitute the PERSON array, which 

c is the central repository of information about inter-relationships 

c static information - filled from PEOPLE file 

character* (NAMLEN) NAME (MAXPRS) 

character* (IDLEN) IDENT (MAXPRS) 

character*l GENDER (MAXPRS) 

c IDENTs of immediate relatives - father, mother, spouse 

character* (IDLEN) RELID (MAXPRS, MAXGVN) 
c pointers to immediate neighbors in graph 

integer NBRCNT (MAXPRS ) 

integer NBRDEX (MAXPRS, MAXNBR) 

integer NBREDG (MAXPRS, MAXNBR) 

c data used when traversing graph to resolve user request: 

real DSTSRC (MAXPRS) 

integer PATHPR (MAXPRS) 

integer EDGPRD (MAXPRS) 

integer RCHST (MAXPRS) 

c data used to compute common genetic material 

character* (IDLEN) DSC ID (MAXPRS) 

real DSCGEN (MAXPRS) 

c NUMPER keeps track of the actual number of persons 
integer NUMPER 

c STACK is common to the routines which calculate genetic overlap, 
c It is used to implement recursive traversal of the ancestor trees. 

integer STKSIZ 
parameter (STKSIZ =50) 

common /STACK/ PROPTN, CONTRB, COUNTD, PERDEX, NXTNBR, 
1 STKPTR 

real PROPTN (STKSIZ) 


real 

CONTRB 

(STKSIZ) 

real 

COUNTD 

(STKSIZ) 

integer 

PERDEX 

(STKSIZ) 

integer 

NXTNBR 

(STKSIZ) 

integer 

STKPTR 


end of 

declarations for common dat. 

character* (IDLEN) 

MARKER 

integer 


MRKDEX, THSNBR 
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MRKDEX - PERDEX (STKPTR) 

if (NXTNBR (STKPTR) .eq. 0) then 

DSC ID (MRKDEX) - MARKER 

DSCGEN (MRKDEX) = DSCGEN (MRKDEX) + PROPTN (STKPTR) 

NXTNBR (STKPTR) = 1 
end if 
do 100 THSNBR = NXTNBR (STKPTR), NBRCNT (MRKDEX) 

if (NBREDG (MRKDEX, THSNBR) .eq. PARENT) goto 101 

100 continue 

101 continue 

if (THSNBR .gt. NBRCNT (MRKDEX)) then 
c no more ancestors from this person 

STKPTR = STKPTR - 1 
else 
c set up for next ancestor 

NXTNBR (STKPTR) = THSNBR + 1 

STKPTR = STKPTR + 1 

PERDEX (STKPTR) = NBRDEX (MRKDEX, THSNBR) 

NXTNBR (STKPTR) = 

PROPTN (STKPTR) = PROPTN (STKPTR - 1) / 2.0 
end if 
end 

subroutine CHKCOM (COMPRP, MTCHID) 
c CHKCOM searches all the ancestors of CHKDEX to see if any have 
c been marked, and if so adds the appropriate amount to COMPRP. 

integer MAXPRS, NAMLEN, IDLEN, BUFLEN, 

1 MSGLEN, MAXNBR, MAXGVN 

parameter (MAXPRS = 300, NAMLEN - 20, IDLEN = 3, BUFLEN - 60, 

1 MSGLEN = 40, MAXNBR = 20, MAXGVN =3) 

character NULLID*( IDLEN) 
parameter (NULLID - '000') 

integer PARENT, CHILD, SPOUSE, SIBLNG, 

1 UNCLE, NEPHEW, COUSIN, NULLRL 

parameter (PARENT = 1, CHILD = 2, SPOUSE = 3, SIBLNG = 4, 

1 UNCLE - 5, NEPHEW = 6, COUSIN = 7, NULLRL - 8) 

c These common blocks hold the PERSON array, which is global to 
c the entire program. 

common /PERNUM/ NBRCNT, NBRDEX, NBREDG, DSTSRC, PATHPR, 
1 EDGPRD, RCHST, DSCGEN, NUMPER 

common /PERCHR/ NAME, IDENT, GENDER, RELID, DSCID 
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c The following data items constitute the PERSON array, which 

c is the central repository of information about inter-relationships, 

c static information - filled from PEOPLE file 

character* (NAMLEN) NAME (MAXPRS) 

character* (IDLEN) IDENT (MAXPRS) 

character*l GENDER (MAXPRS) 

c IDENTs of immediate relatives - father, mother, spouse 

character* (IDLEN) RELID (MAXPRS, MAXGVN) 
c pointers to immediate neighbors in graph 

integer NBRCNT (MAXPRS) 

integer NBRDEX (MAXPRS, MAXNBR) 

integer NBREDG (MAXPRS, MAXNBR) 

c data used when traversing graph to resolve user request: 

real DSTSRC (MAXPRS) 

integer PATHPR (MAXPRS) 

integer EDGPRD (MAXPRS) 

integer RCHST (MAXPRS) 

c data used to compute common genetic material 

character* (IDLEN) DSCID (MAXPRS) 

real DSCGEN (MAXPRS) 

c NUMPER keeps track of the actual number of persons 
integer NUMPER 

c STACK is common to the routines which calculate genetic overlap, 
c It is used to implement recursive traversal of the ancestor trees. 

integer STKSIZ 
parameter (STKSIZ =50) 

common /STACK/ PROPTN, CONTRB, COUNTD, PERDEX, NXTNBR, 
1 STKPTR 


real 

PROPTN 

(STKSIZ) 

real 

CONTRB 

(STKSIZ) 

real 

COUNTD 

(STKSIZ) 

integer 

PERDEX 

(STKSIZ) 

integer 

NXTNBR 

(STKSIZ) 

integer 

STKPTR 


end of 

declarations for co 

real 


COMPRP 

character* (IDLEN) 

MTCHID 

integer 


CHKDEX 
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CHKDEX = PERDEX (STKPTR) 
if (NXTNBR (STKPTR) .eq. 0) then 
NXTNBR (STKPTR) = 1 

if (DSCID (CHKDEX) .eq. MTCHID) then 
c Increment COMPRP by the contribution of this 

c common ancestor, but discount for the contribution 

c of less remote ancestors already counted. 

CONTRB (STKPTR) = DSCGEN (CHKDEX) * PROPTN (STKPTR) 
COMPRP = COMPRP + CONTRB (STKPTR) - COUNTD (STKPTR) 
else 

CONTRB (STKPTR) =0.0 
end if 
end if 
do 100 THSNBR = NXTNBR (STKPTR), NBRCNT (CHKDEX) 

if (NBREDG (CHKDEX, THSNBR) .eq. PARENT) goto 101 

100 continue 

101 continue 

if (THSNBR .gt. NBRCNT (CHKDEX)) then 
c no more ancestors from this person 

STKPTR = STKPTR - 1 
else 
c set up for next ancestor 

NXTNBR (STKPTR) = THSNBR + 1 

STKPTR = STKPTR + 1 

PERDEX (STKPTR) = NBRDEX (CHKDEX, THSNBR) 

NXTNBR (STKPTR) - 

PROPTN (STKPTR) = PROPTN (STKPTR - 1) / 2.0 

COUNTD (STKPTR) = CONTRB (STKPTR - 1) / 4.0 
end if 
end 
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7.0 PASCAL 

User-defined identifiers are written in mixed upper and lower case, rather than 
all upper-case, because Pascal provides no separator character, such as "-" or 
"__" for identifiers. Therefore, upper-case letters are used for readability, 
e.g., EdgeToPredecessor is used in Pascal where EDGE_TO_PREDECESSOR is used in 
most of the other languages . 


program Relate (input, output, People); 

const 

MaxPersons = 300; 

NameLength = 20; 

{ every Person has a unique 3-digit Identifier } 

Identifier Length = 3; 

Buffer Length = 60; 

Re quest Ok = 

'Request OK 
Request To Stop = 

'stop 


type 

Identifier Range 
Buffer Range 
NameRange 
Dig it Type 
NameType 
Buffer Type 
Message Type 
Identifier Type 


= 1. .Identif ierLength; 

= 1 . . Buf f er Leng th ; 

= 1. .NameLength; 

= '0'..'9'; 

= packed array [NameRange] of char; 

= packed array [ Buff er Range] of char; 

- packed array [1..40] of char; 

= array [Identifier Range] of Digit Type; 
{ each Person's record in the file identifies at most three 

others directly related: father, mother, and spouse } 
Givenldentifiers = (Father Ident, Motherldent, Spouseldent) ; 
RelativeArray = array [Givenldentifiers] of Identif ierType ; 
Counter = 0. .maxint; 


{ this is the format of records in the file to be read in } 
FilePersonRecord = record 


Name 

Identifier 

{ 'M' for Male and 

Gender 

Relativeldentifier 

end; 


: NameType ; 

: Identif ierType; 

'F' for Female } 

: char ; 

: RelativeArray 
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IndexType = 0. .MaxPersons ; 

GenderType = (Male, Female); 

RelationType = (Parent, Child, Spouse, Sibling, Uncle, 

Nephew, Cousin, Null Relation); 
{ directed edges in the graph are of a given type } 
Edge Type = Parent . .Spouse; 

{ A node in the graph (= Person) has either already been reached, 

is immediately adjacent to those reached, or farther away. } 
ReachedType = (Reached, Nearby, NotSeen); 

{ each Person has a linked list of adjacent nodes, called neighbors } 
Neighbor Pointer = ~NeighborRecord; 

NeighborRecord - record 

Neighborlndex : IndexType; 
Neighbor Edge : Edge Type; 
NextNeighbor : Neighbor Pointer 
end; 

{ All Relationships are captured in the directed graph of which 

each record is a node . } 
PersonRecord = record 
{ static information - filled from People file: } 

Name : Name Type; 

Identifier : IdentifierType; 

Gender : GenderType; 

{ Identifiers of immediate relatives - father, mother, spouse } 

Relativeldentifier : Relative Array; 

{ head of linked list of adjacent nodes } 

Neighbor ListHeader : Neighbor Pointer; 
{ data used when traversing graph to resolve user request: } 

DistanceFromSource : real; 

PathPredecessor : IndexType ; 

EdgeToPredecessor : EdgeType; 

ReachedStatus : ReachedType; 
{ data used to compute common genetic material } 

Descendant Identifier : IdentifierType; 

Descendant Genes : real 

end; 

var 

{ The Person array is the central repository of information 

about inter-relationships . } 
Person : array [IndexType] of PersonRecord; 

{ These variables are used when establishing the Person array 

from the People file . } 
People : file of File PersonRecord; 

Current, Previous, NumberOf Persons 

: IndexType ; 
Identifier Index : Identifier Range; 
Previous Ident , Current Ident , Null Ident 

: IdentifierType; 
Relationship : Givenldentif iers; 
RelationLoopDone : boolean; 
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{ These variables are used to accept and resolve requests for 

Relationship information. } 
Bufferlndex, SemicolonLocation 

: Buffer Range; 
RequestBuffer : BufferType; 
Personlldent, Person21dent 

: Name Type ; 
PersonlFound, Person2Found 

: Counter ; 
ErrorMessage : Message Type; 
Personllndex , Person2Index 

: IndexType; 

function IdentsEqual (Identa, Identb: Identifier Type) : boolean; 
{ Determines whether two numeric Person-Identifiers are equal. 
A function is necessary because the '=' operator does not 
work for arrays of anything but char. } 
var 

Index : 1. .Identifier Length; 
begin 

IdentsEqual := true; 

for Index := 1 to Identifier Length do 

if Identa [Index] O Identb [Index] then 
IdentsEqual := false 
end; { IdentsEqual } 
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procedure LinkRelatives (Fromlndex : IndexType; 

Relationship : Givenldentifiers; 
To Index : IndexType); 
{ establishes cross- indexing between immediately related Persons. } 

procedure LinkOneWay (Fromlndex : IndexType; 

ThisEdge : EdgeType; 
To Index : IndexType); 
{ Establishes the Neighbor Re cord from one Person to another } 
var 

NewNeighbor : Neighbor Pointer ; 
begin 

new (NewNeighbor); 
with NewNeighbor^ do 
begin 

Neighbor Index := To Index; 
NeighborEdge := ThisEdge; 

NextNeighbor := Person [Fromlndex] . Neighbor ListHeader 
end; 
Person [Fromlndex] . NeighborListHeader := NewNeighbor 
end; 

begin { execution of LinkRelatives } 
if Relationship = Spouseldent then 

begin 

LinkOneWay (Fromlndex, Spouse, To Index); 

LinkOneWay (Toindex, Spouse, Fromlndex) 

end 
else { Relationship is Mother or Father } 

begin 

LinkOneWay (Fromlndex, Parent, Toindex); 

LinkOneWay (Toindex, Child, Fromlndex) 

end 
end; { LinkRelatives } 

procedure PromptAndRead; 

{ Issues prompt for user-request, reads in request, 

blank-fills buffer, and skips to next line of input. } 
var 

Buffer Index : Buffer Range; 
begin 

writeln (' '); 

writeln (' • '); 

writeln (' Enter two person-identifiers (name or number),'); 
writeln (' separated by semicolon. Enter "stop" to stop.'); 
for Buffer Index := 1 to Buffer Length do 
if eoln( input) then 

RequestBuffer [Buffer Index] := ' ' 
else 

read (input, RequestBuffer [Bufferlndex] ); 
readln( input) 
end; { PromptAndRead } 
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procedure CheckRequest (var Request Status : MessageType; 

var SemicolonLocation : Buf f erRange) ; 
{ Performs syntactic check on request in buffer. } 
var 

Buffer Index : Buff erRange; 
SemicolonCount : Counter; 
PersonlFieldExists, Person2FieldExists 

: boolean; 
begin 

Request Status := RequestOk; 
PersonlFieldExists := false; 
Person2FieldExists := false; 
SemicolonCount := 0; 
for Buffer Index := 1 to BufferLength do 

if RequestBuffer [Buffer Index] <> ' " then 
if RequestBuffer [Buf fer Index] = ';' then 
begin 

SemicolonLocation := Buf fer Index; 
SemicolonCount := SemicolonCount + 1 
end 
else { Check for non-blanks before/after semicolon. } 
if SemicolonCount < 1 then 

PersonlFieldExists := true 
else 

Person2FieldExists := true; 
{ set Request Status, based on results of scan of RequestBuffer. } 
if SemicolonCount <> 1 then 

RequestStatus := 'must be exactly one semicolon, 
else 

if not PersonlFieldExists then 

RequestStatus :- 'null field preceding semicolon, 
else 

if not Person2FieldExists then 

RequestStatus := 'null field following semicolon, 
end; { CheckRequest } 

procedure BufferToPerson (var Personld : NameType; 

StartLocation, StopLocation : Buff erRange); 
{ fills in the Personld from the designated portion 
of the RequestBuffer. } 
var 

Bufferlndex : 1..61; { cannot say "BufferLength + 1" } 
Per son Index : Name Range; 
begin 

Bufferlndex := StartLocation; 

while RequestBuffer [Bufferlndex] = ' ' do 

Bufferlndex := Bufferlndex + 1; 
for Personlndex := 1 to NameLength do 
if Bufferlndex > StopLocation then 

Personld [Personlndex] := ' ' 
else 

begin 

Personld [Personlndex] := RequestBuffer [Bufferlndex]; 
Bufferlndex := Bufferlndex + 1 
end 
end; { BufferToPerson } 
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procedure SearchForRequestedPersons (Personlldent, Person2Ident 
var Personllndex, Person2Index : IndexType; 
var PersonlFound, Person2Found : Counter); 
{ SearchForRequestedPersons scans through the Person array, 
looking for the two requested persons. Match may be by name 
or unique identifier-number. } 
var 

Current : IndexType ; 

Thisldent : Name Type; 
Identifier Index : Identifier Range; 
begin 

PersonlFound := 0; 
Person2Found := 0; 

Thisldent := ' '; 

for Current := 1 to Number Of Per sons do 
with Person [Current] do 
begin 
{ Thisldent contains Current Person's numeric Identifier 

left- justified, padded with blanks. } 
for Identifier Index := 1 to IdentifierLength do 

Thisldent [Identifier Index] := Identifier [ Identifier Index] ; 
{ allow identification by name or number. } 
if (Personlldent * Thisldent) or (Personlldent = Name) then 
begin 

PersonlFound := PersonlFound + 1; 
Personllndex : = Current 
end; 
if (Person2Ident = Thisldent) or (Person2Ident ■ Name) then 


NameType ; 


■ Person2Found + 1; 
= Current 


end; 


begin 

Person2Found 
Per son2 Index 
end 
end { with Person [Current] } 
{ SearchForRequestedPersons } 


procedure FindRelat ions hip (Targetlndex, Sourcelndex : IndexType); 
{ Finds shortest path (if any) between two Persons and 

determines their Relationship based on immediate relations 
traversed in path. Person array simulates a directed graph, 
and algorithm finds shortest path, based on following 
weights: Parent-Child edge =1.0 

Spouse-Spouse edge =1.8 } 
var 

SearchStatus : (Searching, Succeeded, Failed); 

Personlndex, ThisNode, Ad jacent Node , Best Nearby Index, Last Nearby Index 

IndexType ; 

array [IndexType] of IndexType; 
EdgeType ; 
Neighbor Pointer ; 
Givenldentif iers ; 
real; 


Nearby Node 
ThisEdge 
This Neighbor 
Relationship 
Minimal Distance 
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procedure ProcessAdjacentNode (BaseNode, NextNode : IndexType; 

NextBaseEdge : EdgeType); 
{ NextNode is adjacent to last-reached node (« BaseNode). 
if NextNode already Reached, do nothing. 
If previously seen, check whether path thru base node is 
shorter than current path to NextNode, and if so re-link 
next to base. 

If not previously seen, link next to base node. } 
var 

WeightThisEdge , DistanceThruBaseNode 

: real; 

procedure LinkNextNodeToBaseNode ; 

{ link next to base by re-setting its predecessor Index to 
point to base, note type of edge, and re-set distance 
as it is through base node. } 
begin { execution of LinkNextNodeToBaseNode } 
with Person [NextNode] do 
begin 


DistanceFrom Source 
Pa thPredeces sor 
EdgeTo Predecessor 
end 
end; { LinkNextNodeToBaseNode } 


= DistanceThruBaseNode; 
= BaseNode; 
= NextBaseEdge 


begin { execution of ProcessAdjacentNode } 
with Person [NextNode] do 

if ReachedStatus <> Reached then 
begin 
if NextBaseEdge = Spouse then 

WeightThisEdge := 1.8 
else 

WeightThisEdge := 1.0; 
DistanceThruBaseNode := WeightThisEdge + 

Person [BaseNode] . DistanceFromSource; 
if ReachedStatus = Not Seen then 
begin 

ReachedStatus := Nearby; 
Last Nearby Index := LastNearby Index + 1; 
NearbyNode [LastNearbylndex] := NextNode; 
LinkNext NodeToBaseNode 
end 
else { ReachedStatus = Nearby } 

if DistanceThruBaseNode < DistanceFromSource then 
LinkNextNodeToBaseNode ; 
end { if ReachedStatus <> Reached } 
end; { ProcessAdjacentNode } 
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procedure ResolvePathToEnglish; 

{ ResolvePathToEnglish condenses the shortest path to a 
series of Relationships for which there are English 
descriptions . } 
type 

{ Key Persons are the ones in the Relationship path which remain 

after the path is condensed. } 
SiblingType = (Step, Half, Full); 
KeyPersonRecord = record 
Personlndex : IndexType ; 
GenerationGap : Counter ; 
Proximity : SiblingType ; 
case RelationToNext : RelationType of 

Parent, Child, Spouse, Sibling, Uncle, Nephew, NullRelation 

: (); 

Cousin : (CousinRank : Counter) 

end; 
var 

{ these variables are used to condense the path } 

Key Person : array [IndexType] of KeyPersonRecord; 

KeyRelation, LaterKeyRelation, PrimaryRelation, NextPrimaryRelation 

: RelationType; 
Generation Count : Counter; 
Key Index, La terKey Index, Primary Index 

: IndexType; 
AnotherElementPossible : boolean; 

function FullSibling (Indexl, Index2 : IndexType) : boolean; 
{ Determines whether two Persons are full siblings, i.e., 
have the same two Parents . } 
var 

Identlndex : 1. . Identifier Length; 
begin 

with Person [Indexl] do 
FullSibling := 

(not IdentsEqual (Relativeldentif ier [Fatherldent] , Nullldent)) and 
(not IdentsEqual (Relativeldentif ier [Motherldent] , Nullldent)) and 
(IdentsEqual (Relativeldentif ier [Fatherldent], 

Person [Index2] . Relative Identifier [Fatherldent] )) and 
(IdentsEqual (Relativeldentif ier [Motherldent] , 

Person [Index2] . Relativeldentif ier [Motherldent] )) 
end; { FullSibling } 

procedure CondenseKeyPersons (Atlndex : IndexType; GapSize : Counter); 
{ CondenseKeyPersons condenses superfluous entries from the 
KeyPerson array, starting at Atlndex. } 
var 

Receivelndex, Sendlndex : IndexType; 
begin 

Receivelndex := Atlndex; 
repeat 

Receivelndex := Receivelndex + 1; 
Sendlndex := Receivelndex + GapSize; 
KeyPerson [Receivelndex] := KeyPerson [Sendlndex]; 
until KeyPerson [Sendlndex] . RelationToNext = NullRelation 
end; { CondenseKeyPersons } 
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procedure Display Relation (Firstlndex, Lastlndex, Primary Index 

: Index Type); 
{ DisplayRelation takes 1, 2, or 3 adjacent elements in the 
condensed table and generates the English description of 
the relation between the first and last + 1 elements. } 
var 

: boolean; 
: Sibling Type; 
: GenderType ; 
: 0..9; 
FirstRelation, LastRelation, PrimaryRelation 

: RelationType ; 
ThisGenerationGap, ThisCousinRank 

: Counter ; 
begin { execution of DisplayRelation } 


Inlaw 

This Proximity 

ThisGender 

Suffixlndicator 


FirstRelation 

LastRelation 

PrimaryRelation 


RelationToNext ; 
RelationToNext ; 
Re la t i onTo Nex t ; 


:= KeyPerson [Firstlndex] 
:= KeyPerson [Lastlndex] 
:= KeyPerson [Primary Index] 
{ set This Proximity } 
if ((PrimaryRelation = Parent) and (FirstRelation = Spouse)) or 

((PrimaryRelation = Child) and (LastRelation = Spouse)) 
then 

ThisProximity := Step 
else 

if PrimaryRelation in 

[Sibling, Uncle, Nephew, Cousin] 

then 

ThisProximity := KeyPerson [Primary Index] . Proximity 

else 

ThisProximity := Full; 
{ set ThisGenerationGap } 

if PrimaryRelation in [Parent, Child, Uncle, Nephew, Cousin] 
then 

ThisGenerationGap := KeyPerson [Primary Index] . GenerationGap 
else 

ThisGenerationGap := 0; 
{ set Inlaw } 
Inlaw := false; 
if (FirstRelation = Spouse) and 

(PrimaryRelation in [Sibling, Child, Nephew, Cousin] ) 
then 

Inlaw := true; 
if (LastRelation = Spouse) and 

(PrimaryRelation in [Sibling, Parent, Uncle, Cousin] ) 
then 

Inlaw := true; 
{ set ThisCousinRank } 
if PrimaryRelation = Cousin then 

ThisCousinRank := KeyPerson [Primary Index] . CousinRank 
else 

ThisCousinRank := 0; 
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{ parameters are set - now generate display. } 


write (' ', Person [Key Person [First Index] . Personlndex] . Name, 

is '); 
if PrimaryRelation in [Parent, Child, Uncle, Nephew] then 
begin { write generation-qualifier } 
if ThisGenerationGap >= 3 then 
begin 

write ('great'); 
if ThisGenerationGap > 3 then 

write ('*', ThisGenerationGap - 2 : 1); 
write ('-') 
end; 
if ThisGenerationGap >= 2 then 

write ('grand-") 
end 
else 

if (PrimaryRelation = Cousin) and (ThisCousinRank > 1) then 
begin 

write (ThisCousinRank : 1); 
Suffixlndicator := ThisCousinRank mod 10; 
case Suffixlndicator of 

1 : write ('st ') 

2 : write ('nd ') 

3 : write ('rd ') 
0, 4, 5, 6, 7, 8, 9 

: write ('th ') 
end 
end; 


if ThisProximity = Step then 

write ('step-') 
else 

if ThisProximity = Half then 
write ('half-'); 


ThisGender := Person [KeyPerson 
case PrimaryRelation of 


[Firstlndex] . Personlndex] . Gender; 


Parent 

Child 

Spouse 

Sibling 

Uncle 

Nephew 

Cousin 

NullRelation 
end; { case } 


if ThisGender 

else 

if ThisGender 

else 

if ThisGender 

else 

if ThisGender 

else 

if ThisGender 

else 

if ThisGender 

else 

write ('cousin 

write ('null') 


= Male then write 

write 
= Male then write 

write 
= Male then write 

write 
= Male then write 

write 
= Male then write 

write 
= Male then write 

write 

); 


('father') 

('mother'); 

('son') 

('daughter'); 

('husband') 

('wife'); 

('brother') 

('sister'); 

('uncle') 

('aunt'); 

('nephew') 

('niece'); 
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if Inlaw then 

write ('-in-law'); 

if (PrimaryRelation = Cousin) and (ThisGenerationGap > 0) then 
if ThisGenerationGap > 1 then 

write (' ', ThisGenerationGap : 1, ' times removed') 
else 

write (' once removed'); 

writeln (' of) 
end; { DisplayRelation } 

begin { execution of ResolvePathToEnglish } 

writeln (' Shortest path between identified persons: '); 
ThisNode := Targetlndex; 
Key Index := 1; 

{ Display path and initialize KeyPerson array from path elements. } 
while ThisNode <> Source Index do 
with Person [ThisNode] do 
begin 

write (' ', Name, ' is '); 
case Edge To Predecessor of 

Parent : writeln ('parent of); 
Child : writeln ('child of); 
Spouse : writeln ('spouse of) 
end; 

KeyPerson [Keylndex] . Personlndex := ThisNode; 
KeyPerson [Keylndex] . Relation To Next := EdgeTo Predecessor; 
if EdgeToPredecessor = Spouse then 

KeyPerson [Keylndex] . GenerationGap := 
else { Parent or Child } 

KeyPerson [Keylndex] . GenerationGap := 1; 
Keylndex := Keylndex + 1; 
ThisNode := PathPredecessor 
end; 
writeln(' ', Person [ThisNode] . Name); 
KeyPerson [Keylndex] . Personlndex := ThisNode; 
KeyPerson [Keylndex] . RelationToNext := NullRelation; 
KeyPerson [Keylndex + 1] . RelationToNext := NullRelation; 
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{ Resolve Child-Parent and Child-Spouse-Parent relations 

to Sibling relations . } 
Key Index := 1; 

while KeyPerson [Keylndex] . RelationToNext <> NullRelation do 
with KeyPerson [Keylndex] do 
begin 

if RelationToNext = Child then 
begin 

LaterKeyRelation := KeyPerson [Keylndex + 1] . RelationToNext; 
if LaterKeyRelation = Parent then 

{ found either full or half siblings } 

begin 

RelationToNext := Sibling; 

if Full Sibling (Per son Index, 

KeyPerson [Keylndex + 2] . Personlndex) 
then 

Proximity := Full 
else 

Proximity := Half; 
CondenseKey Per sons (Keylndex, 1) 
end { processing of full/half siblings } 
else 

if (LaterKeyRelation = Spouse) and 

(KeyPerson [Keylndex +2] . RelationToNext = Parent) 
then { found step-siblings } 
begin 

RelationToNext := Sibling; 
Proximity := Step; 
CondenseKeyPersons (Keylndex, 2) 
end { processing of step-siblings } 
end; { if RelationToNext = Child } 
Keylndex := Keylndex + 1 
end; {with KeyPerson [Keylndex] } 
{ Resolve Child-Child-... and Parent-Parent-... relations to 

direct descendant or ancestor relations. } 
Keylndex := 1; 

while KeyPerson [Keylndex] . RelationToNext <> NullRelation do 
with KeyPerson [Keylndex] do 
begin 

if (RelationToNext = Child) or (RelationToNext = Parent) then 
begin 

LaterKey Index := Keylndex + 1; 

while KeyPerson [Later Key Index] . RelationToNext = 
RelationToNext do 
LaterKey Index := LaterKey Index + 1; 
GenerationCount := Later Keylndex - Keylndex; 
if GenerationCount > 1 then 

begin { compress generations } 
GenerationGap := GenerationCount; 

CondenseKeyPersons (Keylndex, GenerationCount - 1) 
end 
end; { if RelationToNext = Child or Parent } 
Keylndex := Keylndex + 1 
end; {with KeyPerson [Keylndex] } 
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{ Resolve Child-Sibling-Parent to Cousin, 
Child-Sibling to Nephew, 
Sibling-Parent to Uncle. } 
Key Index := 1; 

while KeyPerson [Keylndex] . RelationToNext <> NullRelation do 
with KeyPerson [Keylndex] do 
begin 

LaterKeyRelation := KeyPerson [Keylndex + 1] . RelationToNext; 
if (RelationToNext = Child) and 
(LaterKeyRelation = Sibling) 
then { Cousin or Nephew } 

if KeyPerson [Keylndex + 2] . RelationToNext = Parent then 
{ found Cousin } 
begin 

RelationToNext := Cousin; 

Proximity := KeyPerson [Keylndex + 1] . Proximity; 
if GenerationGap < KeyPerson [Keylndex + 2 ] . GenerationGap 
then 

CousinRank := GenerationGap 
else 

CousinRank := KeyPerson [Keylndex +2] . GenerationGap; 
GenerationGap := abs (GenerationGap - 

KeyPerson [Keylndex + 2] . GenerationGap); 
CondenseKey Per sons (Keylndex, 2) 
end 
else { found Nephew } 
begin 

RelationToNext := Nephew; 

Proximity := KeyPerson [Keylndex + 1] . Proximity; 
CondenseKey Per sons (Keylndex, 1) 
end 
else { not Cousin or Nephew } 

if (RelationToNext = Sibling) and (LaterKeyRelation = Parent) 
then { found Uncle } 
begin 

RelationToNext := Uncle; 

GenerationGap := KeyPerson [Keylndex + 1] . GenerationGap; 
CondenseKey Persons (Keylndex, 1) 
end; 
Keylndex := Keylndex + 1 
end; { with KeyPerson [Keylndex] } 
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{ Loop below will pick out valid adjacent strings of elements 
to be displayed. Key Index points to first element, 
LaterKeylndex to last element, and Primarylndex to the 
element which determines the primary English word to be used. 
Associativity of adjacent elements in condensed table 
is based on English usage. } 
Key Index := 1; 

writeln (' Condensed path:'); 

while KeyPerson [Keylndex] . RelationToNext <> NullRelation do 
begin 

KeyRelation := KeyPerson [Keylndex] . RelationToNext; 
LaterKeylndex := Keylndex; 
Primarylndex := Keylndex; 

if KeyPerson [Keylndex +■ 1] . RelationToNext <> NullRelation then 
begin { seek multi-element combination } 
AnotherElementPossible := true; 
if KeyRelation = Spouse then 
begin 

LaterKeylndex := LaterKeylndex + 1; 
Primarylndex := LaterKeylndex; 
if (KeyPerson [LaterKeylndex] . RelationToNext = Sibling) or 

(KeyPerson [LaterKeylndex] . RelationToNext = Cousin) 
then { Nothing can follow Spouse-Sibling or Spouse-Cousin } 

AnotherElementPossible := false 
end ; 
{ Primarylndex is now correctly set. Next if-statement 
determines if a following Spouse relation should be 
appended to this combination or left for the next 
combination . } 
if AnotherElementPossible and 

(KeyPerson [Primarylndex + 1] . RelationToNext = Spouse) 
{ Only a Spouse can follow a Primary } 
then 

begin { check primary preceding and following Spouse. } 
Primary Relation := 

KeyPerson [Primarylndex] . RelationToNext; 
NextPrimaryRelation : = 

KeyPerson [Primarylndex + 2] . RelationToNext; 
if (NextPrimaryRelation in [Nephew, Cousin, NullRelation] ) 
or (PrimaryRelation = Nephew) 
or ( ( PrimaryRelation in [Sibling, Parent] ) 
and (NextPrimaryRelation <> Uncle ) ) 
then { append following Spouse with this combination. } 

LaterKeylndex := LaterKeylndex + 1 
end { check primary preceding and following Spouse } 
end; { multi-element combination } 
DisplayRelation (Keylndex, LaterKeylndex, Primarylndex); 
Keylndex := LaterKeylndex + 1 
end; { while } 
writeln (' ', Person [KeyPerson [Keylndex] . Personlndex] . Name) 
end; , { ResolvePathToEnglish } 
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procedure Compute Common Genes (Indexl, Index2 : IndexType); 
{ ComputeCommonGenes assumes that each ancestor contributes 
half of the genetic material to a Person. It finds common 
ancestors between two Persons and computes the expected 
value of the Proportion of common material. } 
var 

CommonProportion : real; 

procedure ZeroProportion (Zerolndex : IndexType); 

{ ZeroProportion recursively seeks out all ancestors and 
zeros them out. } 
var 

ThisNeighbor : NeighborPointer; 
begin 

with Person [Zerolndex] do 
begin 

Descendant Genes := 0.0; 
ThisNeighbor := NeighborListHeader 
end; 
while ThisNeighbor <> nil do 
with ThisNeighbor" do 
begin 
if Neighbor Edge = Parent then 

ZeroProportion (Neighbor Index) ; 
ThisNeighbor := NextNeighbor 
end { with } 
end; { ZeroProportion } 

procedure MarkProportion (Marker : Identif ierType ; 

Proportion : real; Marked Index : IndexType); 
{ MarkProportion recursively seeks out all ancestors and 
marks them with the sender's Proportion of shared 
genetic material. This Proportion is diluted by one-half 
for each generation. } 
var 

ThisNeighbor : NeighborPointer; 
begin 

with Person [Markedlndex] do 
begin 


= Marker; 

■ DescendantGenes + Proportion; 

■» NeighborListHeader 


Descendant Identifier 
DescendantGenes 
ThisNeighbor 
end; 
while ThisNeighbor <> nil do 
with This Neighbor * do 
begin 
if NeighborEdge ■ Parent then 

MarkProportion (Marker, Proportion / 2.0, 
Neighborlndex ); 
ThisNeighbor := NextNeighbor 
end 
end; { MarkProportion } 
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procedure CheckCommonProportion 

(var CommonPro port ion : real; 

Matchldentifier : IdentifierType; 
Proportion : real; 
AlreadyCounted : real; 
Check Index : IndexType); 
{ CheckCommonProportion searches all the ancestors of 
Checklndex to see if any have been marked, and if so 
adds the appropriate amount to CommonProportion. } 
var 

ThisNeighbor : NeighborPointer ; 
ThisContribution : real; 
begin 

with Person [Checklndex] do 
begin 

if IdentsEqual (Descendantldentif ier , Matchldentifier) then 
begin 
{ Increment CommonProportion by the contribution of 

this common ancestor, but discount for the contribution 
of less remote ancestors already counted. } 
ThisContribution := Descend ant Genes * Proportion; 
CommonProportion := CommonProportion + 

ThisContribution - AlreadyCounted 
end 
else 

ThisContribution := 0.0; 
ThisNeighbor := NeighborListHeader 
end; { with Person [Checklndex] } 
while ThisNeighbor O nil do 
with ThisNeighbor" do 
begin 
if Neighbor Edge = Parent then 

CheckCommonProportion ( CommonProportion , 
Matchldentifier, Proportion / 2.0, 
ThisContribution / 4.0, 
Neighbor Index ); 
ThisNeighbor := NextNeighbor 
end 
end; { CheckCommonProportion } 

begin { Compute Common Genes } 

{ First zero out all ancestors to allow adding. This is necessary 

because there might be two paths to an ancestor. } 
ZeroProportion (Indexl); 
{ now mark with shared Proportion } 

Mar kPro port ion ( Person [Indexl] . Identifier, 1.0, Indexl); 
CommonProportion := 0.0; 
CheckCommonProportion (CommonProportion, 

Person [Indexl] . Identifier, 1.0, 0.0, Index2); 
writeln (' Proportion of common genetic material = ', 
CommonProportion : 12) 
end; { ComputeCommonGenes } 
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begin { execution of FindRelationship } 
{ initialize Person-array for processing - 

mark all nodes as not seen } 
for Personlndex := 1 to Number Of Per sons do 

Person [Personlndex] . ReachedStatus := Not Seen; 
{ mark source node as Reached } 
ThisNode := Sourcelndex; 
with Person [ThisNode] do 
begin 

ReachedStatus := Reached; 
DistanceFromSource := 0.0 
end; 
{ no Nearby nodes exist yet } 
LastNearby Index := 0; 
if ThisNode = Target Index then 

SearchStatus :■ Succeeded 
else 

SearchStatus := Searching; 
{ Loop keeps processing closest-to-source, unreached node 

until target Reached, or no more connected nodes. } 
while SearchStatus = Searching do 
begin 

{ Process all nodes adjacent to ThisNode } 
ThisNeighbor := Person [ThisNode] . Neighbor ListHeader; 
while ThisNeighbor <> nil do 
with ThisNeighbor" do 
begin 

ProcessAdjacentNode (ThisNode, Neighborlndex, NeighborEdge); 
ThisNeighbor := NextNeighbor 
end; 

{All nodes adjacent to ThisNode are set. Now search for 

shortest-distance unreached (but Nearby) node to process next. } 
if LastNearbylndex = then 

SearchStatus := Failed 
else 

begin 

MinimalDi stance := 1.0e+18; 
for Personlndex := 1 to LastNearbylndex do 
with Person [NearbyNode [Personlndex]] do 

if DistanceFromSource < Minimal Distance then 
begin 

BestNearbylndex := Personlndex; 
Minimal Distance := DistanceFromSource 
end; 
{ Establish new ThisNode } 
ThisNode := NearbyNode [BestNearbylndex] ; 
{ change ThisNode from being Nearby to Reached } 
Person [ThisNode] . ReachedStatus := Reached; 
{ remove ThisNode from Nearby list } 

NearbyNode [BestNearbylndex] :« NearbyNode [LastNearbylndex]; 
LastNearbylndex := LastNearbylndex - 1; 
if ThisNode = Targetlndex then 

SearchStatus := Succeeded 
end { determination of next node to process } 
end; { while SearchStatus = Searching } 
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{ Shortest path between Persons now established. Next task is 
to translate path to English description of Relationship. } 

if SearchStatus = Failed then 

writeln (' ', Person [Targetlndex] . Name, ' is not related to 
Person [Sourcelndex] . Name) 
else { success - parse path to find and display Relationship } 

begin 

ResolvePathTo English; 

ComputeCommonGenes (Sourcelndex, Targetlndex) 

end 

end; { FindRelationship } 

{ *** execution of main sequence begins here *** } 

begin 

for Identifier Index := 1 to IdentifierLength do 

Nullldent [Identifier Index] := '0'; 
reset (People) ; 

{ Current location in array being filled } 
Current := 0; 

{ This loop reads in the People file and constructs the Person 
array from it (one Person = one record = one array entry) . 
As records are read in, links are constructed to represent the 
Parent-Child or Spouse relationship. The array then implements 
a directed graph which is used to satisfy subsequent user 
requests. The file is assumed to be correct - no validation 
is performed on it. } 
while not eof (People) do 
begin 

Current := Current+1; 
with Person [Current] do 
begin 

{ copy direct information from file to array } 
Name := People" . Name; 
Identifier :* People" . Identifier; 
if People" . Gender = 'M' then 

Gender := Male 
else 

Gender :=* Female; 
Relativeldentifier := People" . Relativeldentifier; 
{ Location of adjacent persons as yet undetermined } 
NeighborListHeader := nil; 
{ Descendants as yet undetermined. } 
Descendant Identifier := Nullldent; 
Current Ident := Identifier; 
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{ Compare this Person against all previously entered Persons 

to search for Relationships. } 
for Previous := 1 to (Current-1) do 
begin 

Previous Ident := Person [Previous] . Identifier; 
RelationLoopDone := false; 
Relationship := Fatherldent; 

{ Search for father, mother, or spouse Relationship in 
either direction between this and previous Person. 
Assume at most one Relationship exists. } 
repeat 

if IdentsEqual (Relativeldentif ier [Relationship] , 
Previous Ident) then 
begin 

LinkRelatives (Current, Relationship, Previous); 
RelationLoopDone := true 
end 
else 

if IdentsEqual ( Cur rent Ident , 

Person [Previous] . Relativeldentif ier [Relationship]) 
then 

begin 

LinkRelatives (Previous, Relationship, Current); 
RelationLoopDone := true 
end; 
if Relationship < Spouseldent then 

Relationship := succ (Relationship) 
else 

RelationLoopDone := true; 
until RelationLoopDone 
end; { for Previous } 
get (People) 

end { with Person [Current] } 
end; { while not eof (People) } 
NumberOf Per sons := Current; 

{ Person array is now loaded and edges between immediate relatives 
(Parent-Child or Spouse-Spouse) are established. 

While-loop accepts requests and finds Relationship (if any) 
between pairs of Persons. } 
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reset (input); 

Prompt AndRead ; 

while RequestBuffer <> RequestToStop do 

{ The following code retrieves and validates a user request 
for the Relationship between two identified Persons. } 

begin 

CheckRequest (ErrorMessage, SemicolonLocation) ; 

{ Syntax check of request completed. Now either display error 
message or search for the two Persons. } 

if ErrorMessage = Request Ok then 

begin { Request syntactically correct - 
search for requested Persons. } 
BufferToPerson (Personlldent, 1, SemicolonLocation - 1); 
BufferToPerson (Person2Ident, SemicolonLocation + 1, Buffer Length); 
SearchForRequestedPersons (Personlldent, Person2Ident , 

Personllndex, Person2Index, 
PersonlFound , Person2Found) ; 
if (PersonlFound = 1) and (Person2Found =1) then 
{ Exactly one match for each Person - proceed to 

determine Relationship, if any. } 
if Personllndex = Person2Index then 
begin 
write (' ', Person [Personllndex] . Name, 

' is identical to '); 
if Person [Personllndex] . Gender = Male then 

writeln('himself .') 
else 

writeln( 'herself . ' ) 
end 
else 

FindRelationship (Personllndex, Person2Index) 
else { either not found or more than one found } 
begin 
if PersonlFound = then 

writeln (' First person not found.') 
else 

if PersonlFound > 1 then 

writeln (' Duplicate names for first person - use', 
' numeric identifier.'); 
if Person2Found = then 

writeln (' Second person not found.') 
else 

if Person2Found > 1 then 

writeln (' Duplicate names for second person - use', 
' numeric identifier.') 
end 
end { processing of syntactically legal request } 
else 

writeln (' Incorrect request format: ', ErrorMessage); 
Prompt AndRead 

end; { while RequestBuffer } 
writeln (' End of relation-finder.'); 

end. 
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8.0 PL/I 


In keeping with the general convention of the examples , language- supplied 
keywords and identifiers are written in lower case in the program. To conform 
strictly to the PL/I standard, however, programs must use only upper-case 
letters. In the following program, the logical "Not" operator is represented by 
the graphic character "~". 

RELATE: procedure options (main); 

/* Begin declaration of global data */ 

declare 

/* Used to index relative array, pointing to immediate relatives */ 
( FATHERJEDENT initial (1), 

MOTHER_IDENT initial (2), 

SP0USE_IDENT initial (3), 

/* Used as mnemonics to represent basic English-word relationships. */ 

PARENT initial (1), 

CHILD initial (2), 

SPOUSE initial (3), 

SIBLING initial (4), 

UNCLE initial (5), 

NEPHEW initial (6), 

COUSIN initial (7), 

NULL_RELATI0N initial (8), 

/* Used as mnemonics to represent status of nodes during search 
for shortest path thru graph. */ 

REACHED initial (1), 

NEARBY initial (2), 

N0T_SEEN initial (3) ) 
fixed binary (4,0), 

/* Used as mnemonics to represent truth-values */ 
( TRUE initial ('l'b), 

FALSE initial ('0'b)) 

bit (1), 

/* Used to control user requests. */ 

( REQUEST_0K character (10) initial ('Request OK'), 
REQUEST_T0_ST0P character (4) initial ('stop')), 

/* Used as mnemonics to represent GENDER */ 
( MALE initial ('M'), 

FEMALE initial ('F')) 

character (1); 
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declare 

/* the PERSON array is the central repository of information 

about inter-relationships. */ 
/* All relationships are captured in the directed graph of which 
each record is a node. */ 
01 PERSON dimension (1:300), 

/* static information - filled from PEOPLE file: */ 
05 NAME character (20), 

05 IDENTIFIER picture '999', 

05 GENDER character (1), 

/* IDENTIFIERS of immediate relatives - father, mother, spouse */ 
05 RELATIVE_IDENTIFIER (1:3) 

picture '999', 
/* head of linked list of adjacent nodes */ 
05 NEIGHB0R_LIST_HEADER pointer , 

/* data used when traversing graph to resolve user request : */ 
05 DISTANCE_FR0M_S0URCE float decimal (6), 
05 PATH_PREDECESSOR fixed binary (10,0), 
05 EDGE_T0_PREDECESS0R fixed binary (4,0), 
05 REACHED_STATUS fixed binary (4,0), 
/* data used to compute common genetic material */ 
05 DESCENDANT_IDENTIFIER picture '999', 
05 DESCENDANTJ3ENES float decimal (6); 

declare 

/* each PERSON has a linked list of adjacent nodes, called neighbors */ 
01 NEIGHB0R_REC0RD based (NEW_NEIGHB0R) , 

05 NEIGHB0R_INDEX fixed binary (10,0), 
05 NEIGHB0R_EDGE fixed binary (4,0), 
05 NEXT_NEIGHB0R pointer; 

/* End declaration of global data. */ 

declare 

/* This is the format of records in the file to be read in. */ 
01 PE0PLE_REC0RD, 

05 NAME character (20), 

05 IDENTIFIER picture '999', 

/* 'M' for MALE and 'F' for FEMALE */ 
05 GENDER character (1), 

05 RELATIVE_IDENTIFIER (1:3) picture '999'; 

declare 

/* These variables are used when establishing the PERSON array 

from the PEOPLE file. */ 
PEOPLE file record sequential input, 

(CURRENT, PREVIOUS, NUMBER_0F_PERS0NS ) 

fixed binary (10,0), 
(PREVI0US_IDENT, CURRENT_IDENT) 

picture '999', 
NULL_IDENT picture '999' static initial (000), 

RELATIONSHIP fixed binary (4,0), 
RELATI0N_L00P_D0NE bit (1), 
END OF PEOPLE bit (1); 
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declare 

/* These variables are used to accept and resolve requests for 

RELATIONSHIP information. */ 
sysin file record input environment (AREAD), 
(BUFFER_INDEX, SEMICOLON_LOCATION) 

fixed binary (10,0), 
REQUEST_BUFFER character (60) varying, 
(PERS0N1_IDENT, PERS0N2_IDENT) 

character (20), 
(PERS0N1_F0UND, PERS0N2_F0UND) 

fixed binary (10,0), 
character (40), 
PERS0N2_INDEX) 

fixed binary (10,0); 


ERROR_MESSAGE 
(PERS0N1 INDEX, 


/* This on-block captures exceptions from the following code */ 
on endfile (PEOPLE) 

begin; 

END_0F_PE0PLE = TRUE; 

end; 
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/* *** begin execution of main sequence RELATE *** */ 

open file (PEOPLE) title ('PEOPLE.DAT'); 
END_OF_PEOPLE = FALSE; 

/* This loop reads in the PEOPLE file and constructs the PERSON 
array from it (one PERSON = one record = one array entry). 
As records are read in, links are constructed to represent the 
PARENT -CHILD or SPOUSE RELATIONSHIP. The array then implements 
a directed graph which is used to satisfy subsequent user 
requests. The file is assumed to be correct - no validation 
is performed on it. */ 
read file (PEOPLE) into (PEOPLE_RECORD); 
READ_IN_PEOPLE: 

do CURRENT = 1 to 300 while (~ END_0F_PE0PLE); 
/* copy direct information from file to array */ 
PERSON (CURRENT) = PE0PLE_REC0RD, by name; 
/* Location of adjacent persons as yet undetermined. */ 
PERSON (CURRENT) . NEIGHBOR_LIST_HEADER = null(); 
/* Descendants as yet undetermined */ 

PERSON (CURRENT) . DESCENDANTJEDENTIFIER = NULL_IDENT; 
CURRENT_IDENT = PERSON (CURRENT) . IDENTIFIER; 
/* Compare this PERSON against all previously entered PERSONS 
to search for RELATIONSHIPS. */ 
C0MPARE_T0_PRE VTOUS : 

do PREVIOUS = 1 to (CURRENT-1); 

PREVIOUS_IDENT = PERSON (PREVIOUS) . IDENTIFIER; 
RELATI0N_L00P_D0NE = FALSE; 

/* Search for father, mother, or spouse relationship in 
either direction between this and PREVIOUS PERSON. 
Assume at most one RELATIONSHIP exists. */ 
TRY_ALL_RELATIONSHIPS : 

do RELATIONSHIP = FATHER_IDENT to SP0USE_IDENT 
while (~ RELATI0N_L00P_D0NE); 
if PERSON (CURRENT) . RELATIVEJLDENTIFIER (RELATIONSHIP) = 
PREVIOUS_IDENT then 
do; 

call LINK_RELATIVES (CURRENT, RELATIONSHIP, PREVIOUS); 
RELATI0N_L00P_D0NE - TRUE; 
end; 
else 

if CURRENTJDENT = 

PERSON (PREVIOUS) . RELATIVE_IDENTIFIER (RELATIONSHIP) 
then 
do; 

call LINK_RELATIVES (PREVIOUS, RELATIONSHIP, CURRENT); 
RELATI0N_L00P_D0NE = TRUE; 
end; 
end TRY_ALL_RELATIONSHIPS ; 
end COMPARE_TO_PREVIOUS ; 
read file (PEOPLE) into (PE0PLE_REC0RD); 
end READ_IN_PE0PLE ; 
NUMBER_0F_PERS0NS = CURRENT - 1; 
close file (PEOPLE); 

/* PERSON array is now loaded and edges between immediate relatives 
(PARENT-CHILD or SPOUSE -SPOUSE) are established. 
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While-loop accepts requests and finds RELATIONSHIP (if any) 
between pairs of PERSONS . */ 

call PROMPT_AND_READ(); 
READ_AND_PROCESS_REQUEST : 

do while (REQUEST_BUFFER ~= REQUEST_TO_STOP); 

/* The following code retrieves and validates a user request 

for the RELATIONSHIP between two identified PERSONS . */ 
call CHECK_REQUEST (ERROR_MESSAGE, SEMICOLONJLOCATION); 

/* Syntax check of request completed. Now either display error 
message or search for the two PERSONS . */ 

if ERROR_MESSAGE = REQUESTJDK then 

do; /* Request syntactically correct - 

search for requested PERSONS. */ 
call BUFFER_TO_PERSON ( PERSON 1_I DENT, 1, SEMICOLONJLOCATION - 1); 
call BUFFER_TO_PERSON (PERS0N2_IDENT, SEMICOL0N_LOCATION + 1, 

length (REQUESTJBUFFER) ) ; 
call SEARCH_FOR_REQUESTED_PERSONS (PERS0N1_IDENT, PERS0N2_IDENT, 

PERSONIJLNDEX, PERS0N2_INDEX, 
PERSON 1_F0UND, PERS0N2_F0UND); 
if (PERS0N1_F0UND = 1) & (PERS0N2_F0UND = 1) then 
/* Exactly one match for each PERSON - proceed to 

determine RELATIONSHIP, if any. */ 
if PERSON 1_INDEX = PERS0N2_INDEX then 

if PERSON (PERS0N1_INDEX) . GENDER = MALE then 

put skip list (' ' || PERSON (PERS0N1_INDEX) . NAME || 
is identical to himself.'); 
else 

put skip list (''II PERSON (PERS0N1_INDEX) . NAME | i 
is identical to herself.'); 
else 

call FIND_RELATIONSHIP (PERS0N1_INDEX, PERS0N2JLNDEX); 
else /* either not found or more than one found */ 
do; 
if PERS0N1_F0UND - then 

put skip list (' First person not found.'); 
else 

if PERSON1JF0UND > 1 then 

put skip list (' Duplicate names for first person - use' 
numeric identifier.'); 
if PERS0N2_F0UND = then 

put skip list (' Second person not found.'); 
else 

if PERS0N2_F0UND > 1 then 

put skip list (' Duplicate names for second person - use' 
numeric identifier.'); 
end; 
end; /* processing of syntactically legal request */ 
else 

put skip list (' Incorrect request format: ' I I ERROR_MESSAGE); 
call PROMPT_AND_READ(); 
end READ_AND_PROCESS_REQUEST; 
put skip list (' End of relation-finder.'); 
/* End execution of main sequence RELATE 
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procedures under RELATE begin here */ 

LINK_RELATIVES: procedure (FROM_INDEX, RELATIONSHIP, T0_INDEX); 

declare 

FROM_INDEX fixed binary (10,0), 

RELATIONSHIP fixed binary (4,0), 

T0_INDEX fixed binary (10,0); 

/* begin execution of LINK_RELATIVES */ 

if RELATIONSHIP = SP0USE_IDENT then 

do; 

call LINK_0NE_WAY (FR0M_INDEX, SPOUSE, T0_INDEX); 

call LINKJONEJWAY (T0_INDEX, SPOUSE, FR0M_INDEX); 

end; 
else /* RELATIONSHIP is mother or father */ 

do; 

call LINK_0NE_WAY (FR0M_INDEX, PARENT, T0_INDEX); 

call LINKJONEJWAY (T0_INDEX, CHILD, FR0M_INDEX); 

end; 

LINKJDNEJWAY: procedure (FR0M_INDEX, THIS_EDGE, T0_INDEX); 

declare 

FROM_INDEX fixed binary (10,0), 

THIS_EDGE fixed binary (4,0), 

T0_INDEX fixed binary (10,0); 

declare 

NEW_NEIGHBOR pointer; 

/* begin execution of LINK_0NE_WAY */ 

allocate NEIGHB0R_REC0RD set (NEW_NEIGHB0R); 
NEWJNEIGHBOR -> NEIGHB0R_INDEX = T0_INDEX; 
NEW_NEIGHBOR -> NEIGHB0R_EDGE = THIS_EDGE ; 
NEW_NEIGHB0R -> NEXT_NEIGHB0R = 

PERSON (FR0M_INDEX) . NEIGHBOR_LISTJiEADER; 
PERSON (FROM_INDEX) . NEIGHB0R_LIST_HEADER = NEWJNEIGHBOR; 
end LINK_ONE_WAY; 

end LINK_RELATIVES ; 

PROMPT_AND_READ : pr ocedur e ; 

/* Issues prompt for user-request, reads in request, 

blank-fills buffer, and skips to next line of input. */ 

declare BUFFER_INDEX fixed binary (10,0), 

SEMICOLON COUNT fixed binary (4,0); 
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/* begin execution of PROMPT_AND_READ */ 

put skip (2) list (' '); 

put skip list (' Enter two person-identifiers (name or number),'); 
put skip list (' separated by semicolon. Enter "stop" to stop.'); 
put skip list (' '); 

/* The use of sysin for record-oriented, rather than stream-oriented, 
input may not be considered to be standard usage. It is done here 
because stream input cannot recognize line boundaries, so as to 
read an entire line from the terminal. */ 
read file (sysin) into (REQUESTJBUFFER); 

end PROMPT_AND_READ; 

CHECK_REQUEST: procedure (REQUESTJSTATUS, SEMICOLONJLOCATION); 
/* Performs syntactic check on request in buffer. */ 

declare 

REQUESTJSTATUS character (40), 

SEMIC0L0N_L0CATI0N fixed binary (10,0); 

/* begin execution of CHECK_REQUEST */ 

SEMICOLON JL0CATI0N = index (REQUEST_BUFFER, ';'); 
if SEMICOLON_L0CATION = | 

index (substr (REQUESTJBUFFER, SEMIC0L0NJL0CATI0N +1), ';') > 
then 

REQUEST_STATUS = 'must be exactly one semicolon.'; 
else 

if before (REQUEST_BUFFER, ';') = ' ' then 

REQUEST_STATUS = 'null field preceding semicolon.'; 
else 

if after (REQUEST_BUFFER, ';') = ' ' then 

REQUEST_STATUS = 'null field following semicolon.'; 
else 

REQUEST_STATUS = REQUEST_0K; 
end CHECKJRE QUEST; 

BUFFER_T0_PERS0N: procedure (PERSONJD, STARTJLOCATI0N, ST0PJL0CATI0N); 
/* fills in the PERS0N_ID from the designated portion 
of the REQUESTJBUFFER. */ 

declare 

PERSONJED character (20), 

(STARTJLOCATION, ST0P_L0CATI0N) 

fixed binary (10,0); 
declare 

FIRST_NON_BLANK fixed binary (10,0); 

/* begin execution of BUFFER_T0_PERS0N */ 

do FIRST_NON_BIANK = START_L0CATI0N to ST0P_L0CATI0N 

while (substr (REQUESTJBUFFER, FIRSTJNONJBLANK, 1) = ' '); 
end; 
PERS0N_ID - substr (REQUESTJBUFFER, FIRST_N0NJBLANK, 

ST0PJL0CATI0N - FIRSTJJONJBLANK +1); 
end BUFFER TO PERSON; 
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SEARCH_FOR_REQUESTED_PERSONS: procedure (PERS0N1JLDENT, PERS0N2_IDENT, 

PERSONl_INDEX, PERS0N2_INDEX, 
PERS0N1_F0UND, PERS0N2_F0UND); 
/* SEARCH_FOR_REQUESTED_PERSONS scans through the PERSON array, 
looking for the two requested PERSONS . Match may be by NAME 
or unique IDENTIF IER-number . */ 
declare 

PERS0N2_IDENT) character (20), 
PERSON2_INDEX) fixed binary (10,0), 
PERS0N2 FOUND) fixed binary (10,0); 


(PERS0N1_IDENT, 
(PERS0N1_INDEX, 
(PERS0N1_F0UND, 
declare 

THIS_IDENT 
CURRENT 


character (20), 
fixed binary (10,0); 
/* begin execution of SEARCH_F0R_REQUESTED_PERS0NS */ 
PERS0N1_F0UND = 0; 
PERS0N2_F0UND = 0; 
SCAN_ALL_PERS0NS : 

do CURRENT = 1 to NUMBER_0F_PERS0NS ; 

/* THIS_IDENT contains CURRENT PERSON'S numeric IDENTIFIER 

left- justified, padded with blanks. */ 
THIS_IDENT = PERSON (CURRENT) . IDENTIFIER; 
/* allow identification by name or number. */ 
if (PERS0N1_IDENT = THIS_IDENT) | 

(PERS0N1JLDENT = PERSON (CURRENT) . NAME) 
then 
do; 

PERS0N1_F0UND - PERS0N1_F0UND + 1; 
PERS0N1_INDEX = CURRENT; 
end; 
if (PERS0N2_IDENT = THIS_IDENT) | 

(PERS0N2_IDENT = PERSON (CURRENT) . NAME) 
then 
do; 

PERS0N2_F0UND = PERS0N2_F0UND + 1; 
PERS0N2_INDEX = CURRENT; 
end; 
end SCAN_ALL_PERS0NS ; 
end SEARCH FOR REQUESTED PERSONS; 


/* End of utility procedures under RELATE. 
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FIND_RELATIONSHIP does major work of program: determines 
relationship between any two people in PERSON array. */ 

FIND_RELATIONSHIP: procedure (TARGET_INDEX, SOURCE_INDEX); 
/* Finds shortest path (if any) between two PERSONS and 

determines their RELATIONSHIP based on immediate relations 
traversed in path. PERSON array simulates a directed graph, 
and algorithm finds shortest path, based on following 
weights: PARENT -CHILD edge =1.0 

SPOUSE -SPOUSE edge =1.8 */ 
declare 

(TARGET_INDEX, SOURCE_INDEX) fixed binary (10,0); 
declare 

SEARCH_STATUS character (1), 

/* values for SEARCH_STATUS */ 
(SEARCHING initial ('?'), 

SUCCEEDED initial ('!'), 

FAILED initial ('X')) character (1), 

(PERS0N_INDEX, THIS_N0DE, AD JACENT_N0DE , BEST_NEARBY_INDEX, 
LAST_NEARBY_INDEX) fixed binary (10,0), 
NEARBY_NODE dimension (1:300) fixed binary (10,0), 

THIS_EDGE fixed binary (4,0), 

THIS_NEIGHB0R pointer , 

RELATIONSHIP fixed binary (4,0), 

MINIMAL_DI STANCE float decimal (6); 

/* begin execution of FIND_RELATI0NSHIP */ 
/* initialize PERSON-array for processing - 

mark all nodes as not seen */ 
PERSON . REACHED_STATUS = NOT_SEEN; 
/* mark source node as REACHED */ 
THIS_N0DE = SOURCE_INDEX; 

PERSON (THIS_N0DE) . REACHED_STATUS = REACHED; 
PERSON (THIS_N0DE) . DISTANCE_FR0M_S0URCE = 0.0; 
/* no NEARBY nodes exist yet */ 
LAST_NEARBY_INDEX = 0; 
if THIS_N0DE = TARGETJNDEX then 

SEARCH_STATUS = SUCCEEDED; 
else 

SEARCH STATUS = SEARCHING; 
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/* Loop keeps processing closest-to-source, unREACHED node 
until target REACHED, or no more connected nodes . */ 
SEARCH_FOR__TARGET : 

do while (SEARCH_STATUS = SEARCHING); 

/* Process all nodes adjacent to THISJJODE */ 
THIS_NEIGHBOR - PERSON (THIS_NODE) . NEIGHBOR_LIST_HEADER; 
do while (THIS_NEIGHBOR ~= null()); 

call PROCESS_ADJACENT_NODE (THISJJODE, 

THIS_NEIGHBOR -> NEIGHBOR JNDEX, 
THIS_NEIGHBOR -> NEIGHBOR_EDGE); 
THISJJEIGHBOR = THIS_NEIGHBOR -> NEXT_NEIGHBOR; 
end; 

/* All nodes adjacent to THIS_NODE are set. Now search for 

shortest-distance unREACHED (but NEARBY) node to process next. */ 
if LASTJJEARBYJNDEX = then 

SEARCHJSTATUS - FAILED; 
else 
do; 

MINIMAL_DISTANCE « 1.0e+18; 
do PERSON_INDEX = 1 to LASTJJEARBYJNDEX; 

if PERSON (NEARBY_NODE (PERSONJNDEX)) . DISTANCE_FROM_SOURCE 
< MINIMAL_DISTANCE then 
do; 

BEST_NEARBY_INDEX = PERSON_INDEX; 
MINIMAL J)I STANCE = 

PERSON (NEARBY_NODE (PERSON_INDEX)) . DISTANCE_FROM_S0URCE ; 
end; 
end; /* PERSON_INDEX loop */ 
/* establish new THIS_NODE */ 
THISJJODE = NEARBY_NODE (BEST_NEARBY_INDEX); 
/* change THISJJODE from being NEARBY to REACHED */ 
PERSON (THISJJODE) . REACHED_STATUS = REACHED; 
/* remove THISJJODE from NEARBY list */ 

NEARBYJJODE (BESTJJEARBYJNDEX) = NEARBYJJODE (LASTJJEARBYJNDEX); 
LASTJJEARBYJNDEX = LASTJJEARBYJENDEX - 1; 
if THISJJODE = TARGET JNDEX then 

SEARCH_STATUS = SUCCEEDED; 
end; /* determination of next node to process */ 
end SEARCH JORJTARGET; 

/* Shortest path between PERSONS now established. Next task is 
to translate path to English description of RELATIONSHIP. */ 

if SEARCHJSTATUS = FAILED then 

put skip list (' ', PERSON (TARGET JNDEX) . NAME, ' is not related to 
PERSON ( SOURCE J!NDEX) . NAME); 
else /* success - parse path to find and display RELATIONSHIP */ 

do; 

call RESOLVE _PATH_TO_ENGLISH; 

call COMPUTE_C0MMON_GENES (SOURCE_INDEX, TARGET_INDEX); 

end; 

/* End execution of FIND RELATIONSHIP. 
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Utility procedures begin here. */ 

PROCESS_ADJACENT_NODE : procedure (BASE_NODE, NEXT_NODE, NEXT_BASE_EDGE ) ; 
/* NEXT_N0DE is adjacent to last-REACHED node (= BASE_NODE). 
if NEXT_NODE already REACHED, do nothing. 
If previously seen, check whether path thru BASE_NODE is 
shorter than current path to NEXT_NODE, and if so re-link 
next to base. 

If not previously seen, link next to base node. */ 
declare 

(BASE_NODE, NEXTJJODE) fixed binary (10,0), 
NEXT_BASE_EDGE fixed binary (4,0); 

declare 

(WEIGHT_THIS_EDGE , DISTANCE_THRU_BASE_NODE ) 

float decimal (6); 

/* begin execution of PR0CESS_ADJACENT_N0DE */ 

if PERSON (NEXT_N0DE) . REACHED_STATUS ~= REACHED then 
do; 
if NEXT_BASE_EDGE = SPOUSE then 

WEIGHT_THIS_EDGE =1.8; 
else 

WEIGHT_THIS_EDGE = 1.0; 
DISTANCE_THRU_BASE_NODE = WEIGHT_THIS_EDGE + 

PERSON (BASE_NODE) . DISTANCE_FROM_SOURCE ; 
if PERSON (NEXTJNODE) . REACHED_STATUS = N0T_SEEN then 
do; 

PERSON (NEXT_N0DE) . REACHED_STATUS - NEARBY; 
LAST_NEARBY_INDEX = LAST_NEARBY_INDEX + 1; 
NEARBY_NODE (LAST_NEARBY_INDEX) = NEXTJJODE; 
call LINK_NEXT_N0DE_T0_BASE_N0DE ; 
end; 
else /* REACHED_STATUS = NEARBY */ 
if DISTANCE_THRU_BASE_NODE < 

PERSON (NEXTJJODE) . DISTANCE_FR0M_S0URCE then 
call LINK_NEXT_N0DE_T0_BASE_N0DE ; 
end; /* if REACHED_STATUS not = REACHED */ 

LINK_NEXT_N0DE_T0_BASE_N0DE : procedure ; 
/* link next to base by re-setting its predecessor index to 
point to base, note type of edge, and re-set distance 
as it is through base node. */ 
/* begin execution of LINK_NEXT_NODE_TO_BASE_NODE */ 

PERSON (NEXT_N0DE) . DISTANCE_FR0M_S0URCE = DISTANCE_THRU_BASE_NODE ; 
PERSON (NEXTJJODE) . PATH_PREDECESSOR - BASE_N0DE; 

PERSON (NEXTJJODE) . EDGE_T0_PREDECESS0R = NEXT_BASE_EDGE ; 
end LINK_NEXT_N0DE_T0_BASE_N0DE ; 

end PR0CESS_ADJACENT_N0DE ; 

/* End utility procedures under FIND RELATIONSHIP. 
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Begin two major procedures: RESOLVE_PATH_TO_ENGLISH and 
COMPUTE_COMMON_GENES */ 

RESOLVE_PATH_TO_ENGLISH: procedure; 

/* RESOLVE_PATH_TO_ENGLISH condenses the shortest path to a 
series of RELATIONSHIPS for which there are English 
descriptions . */ 
/* Key persons are the ones in the RELATIONSHIP path which remain 

after the path is condensed. */ 
declare 

/* values for sibling proximity */ 
(STEP initial ('S'), 
HALF initial ('H'), 
FULL initial ('F')) character (1); 
declare 

01 KEY PERSON dimension (1:300), 


05 

PERSON INDEX 

fixed binary (10,0), 

05 

GENERATION_GAP 

fixed binary (10,0), 

05 

PROXIMITY 

character (1), 

05 

RELATION TO NEXT 

fixed binary (4,0), 

05 

COUSIN RANK 

fixed binary (10,0); 


declare 

/* these variables are used to condense the path */ 
(KEY_RELATI0N, LATER_KEY_RELATI0N, PRIMARY_RELATI0N, 
NEXT_PRIMARY_RELATION) fixed binary (4,0), 

GENERATION^ OUNT fixed binary (10,0), 

(KEY_INDEX, LATER_KEY_INDEX, PRIMARY_INDEX) 

fixed binary (10,0), 
AN0THER_ELEMENT_P0SSIBLE bit (1); 

/* begin execution of RES0LVE_PATH_T0_ENGLISH */ 

put skip list (' Shortest path between identified persons: '); 
THIS_N0DE = TARGET_INDEX; 

/* Display path and initialize KEY_PERS0N array from path elements. */ 
TRAVERSE_SHORTEST_PATH : 

do KEYJLNDEX = 1 to 300 while (THIS_N0DE ~= SOURCE_INDEX); 
begin; 
declare 

EDGE_TYPE dimension (1:3) character (9) static 

initial ('parent of, 'child of, 'spouse of); 
put skip list (' ' | | PERSON (THIS_N0DE) . NAME | | ' is ' I I 
EDGE_TYPE (PERSON (THIS_N0DE) . EDGE_T0_PREDECESS0R)); 
end; 

KEY_PERS0N (KEY_INDEX) . PERSON_INDEX = THISJJODE ; 

KEY_PERSON (KEY_INDEX) . RELATION_TO_NEXT = 
PERSON (THISJJODE) . EDGE_T0_PREDECESS0R; 
if PERSON (THIS_N0DE) . EDGE_TO_PREDECESSOR = SPOUSE then 

KEY_PERSON (KEYJENDEX) . GENERATION_GAP = 0; 
else 

KEY_PERSON (KEYJLNDEX) . GENERATION_GAP = 1; 
THIS_N0DE = PERSON (THIS_N0DE) . PATH_PREDECESSOR; 
end TRAVERSE_SH0RTEST_PATH; 
put skip list(' ' || PERSON (THIS NODE) . NAME); 
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KEY_PERSON (KEYJENDEX) . PERSON_INDEX = THIS_NODE; 

KEY_PERSON (KEYJENDEX) . RELATION_TO_NEXT = NULL_RELATION; 

KEY_PERSON (KEYJENDEX + 1) . RELATION JTO_NE XT = NULL _RELATION ; 
/* Resolve CHILD-PARENT and CHILD-SPOUSE -PARENT relations 
to SIBLING relations. */ 
FIND_SIBLINGS: 

do KEYJENDEX = 1 to 300 

while (KEY_PERS0N (KEYJENDEX) . RELATIONJTO_NEXT ~= NULL_RELATI0N); 
if KEYJ > ERSON (KEYJ1NDEX) . RELATION JTOJJE XT = CHILD then 
do; 

IATER_KEY_RELATION = KEYJ>ERSON (KEYJNDEX + 1) . RELATION_TO_NEXT ; 
if LATER_KEYJtELATION = PARENT then 

/* found either full or half SIBLINGS */ 
do; 

KEYJ?ERS0N (KEYJENDEX) . RELATION J'0_NEXT = SIBLING; 
if FULL_SIBLING (KEYJ>ERSON (KEYJNDEX) . PERSON_INDEX, 

KEY_PERSON (KEYJENDEX + 2) . PERSON J!NDEX) 
then 

KEYJ>ERSON (KEYJNDEX) . PROXIMITY = FULL; 
else 

KEYJ>ERSON (KEYJNDEX) . PROXIMITY = HALF; 
call CONDENSE_KEYJ»ERSONS (KEY_INDEX, 1); 
end; /* processing of full/half SIBLINGS */ 
else 

if (LATER JCEY_RELATION = SPOUSE) & 

(KEY_PERSON (KEYJ1NDEX + 2) . RELATIONJTO_NEXT = PARENT) 
then /* found step-SIBLINGs */ 
do; 

KEY_PERSON (KEYJENDEX) . RELATION J!0_NEXT = SIBLING; 
KEYJ'ERSON (KEYJENDEX) . PROXIMITY = STEP; 

call CONDENSE_KEYJ»ERSONS (KEYJENDEX, 2); 
end; /* processing of step-SIBLINGs */ 
end; /* if RELATIONJTOJJEXT - CHILD */ 
end FIND_SIBLINGS; 

/* Resolve CHILD-CHILD-. . . and PARENT-PARENT-. . . relations to 
direct descendant or ancestor relations . */ 
FIND_ANCESTORS J)RJ>E SCENDANTS : 
do KEYJENDEX = 1 to 300 

while (KEYJ»ERSON (KEYJENDEX) . RELATION JT0_NEXT ~= NULL_RELATION); 
if (KEYJ>ERS0N (KEY_INDEX) . RELATION JT0_NE XT - CHILD) | 

(KEYJ>ERS0N (KEYJENDEX) . RELATIONJOJIEXT - PARENT) 
then 
do; 
do LATER_KEYJNDEX = KEYj:NDEX + 1 to 300 

while (KEY_PERS0N ( LATER JCEYJENDEX) . RELATI0NJT0_NEXT = 
KEYJ>ERS0N (KEYJENDEX) . RELATIONJTOJJEXT); 

end; 

GENERATIONJOUNT = LATER_KEYj:NDEX - KEYj:NDEX; 
if GENERATION JSOUNT > 1 then 

do ; /* compress generations */ 

KEYJ»ERSON (KEY_INDEX) . GENERATI0N_GAP = GENERATION JCOUNT ; 
call CONDENSE_KEYJPERSONS (KEYJNDEX, GENERATIONJSOUNT - 1); 
end; 
end; /* if RELATIONJTOJJEXT ■ CHILD or PARENT */ 
end FIND ANCESTORS OR DESCENDANTS; 
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/* Resolve CHILD-SIBLING-PARENT to COUSIN, 
CHILD-SIBLING to NEPHEW, 

SIBLING-PARENT to UNCLE. */ 

F IND_COUSINS_NE PHEWSJJNCLE S : 
do KEY_INDEX = 1 to 300 

while (KEYJPERSON (KEY_INDEX) . RELATI0N_T0_NEXT ~= NULL_RELATI0N); 
LATER_KEY_RELATION = KEY_PERSON (KEY_INDEX + 1) . RELATI0N_T0_NEXT; 
if (KEY_PERS0N (KEY_INDEX) . RELATI0N_T0_NEXT = CHILD) & 

(LATER_KEY_RELATI0N = SIBLING) 
then /* COUSIN or NEPHEW */ 

if KEY_PERS0N (KEYJLNDEX + 2) . RELATI0N_T0_NEXT = PARENT then 
/* found COUSIN */ 
do; 

KEY_PERS0N (KEY_INDEX) . RELATI0N_T0_NEXT = COUSIN; 
KEY_PERS0N (KEY_INDEX) . PROXIMITY = 

KEY_PERSON (KEY_INDEX + 1) . PROXIMITY; 
KEY_PERSON (KEYJLNDEX) . COUSIN_RANK = 

min (KEYJPERSON (KEY_INDEX) . GENERATION_GAP, 

KEY_PERSON (KEYJLNDEX + 2) . GENERATION_GAP ) ; 
KEYJ>ERSON (KEYJ!NDEX) . GENERATI0NJ3AP = 

abs (KEYJPERSON (KEY_INDEX) . GENERATION_GAP - 

KEY_PERSON (KEYJLNDEX + 2) . GENERATIONJ3AP); 
call CONDENSE JKEY_PERSONS (KEY_INDEX, 2); 
end; 
else /* found NEPHEW */ 
do; 

KEY_PERS0N (KEYJLNDEX) . RELATIONJTO_NEXT = NEPHEW; 
KEY_PERS0N (KEY_INDEX) . PROXIMITY = 

KEYJ>ERSON (KEYJLNDEX + 1) . PROXIMITY; 
call CONDENSE_KEY_PERSONS (KEY_INDEX, 1); 
end; 
else /* not COUSIN or NEPHEW */ 

if (KEY_PERSON (KEY_INDEX) . RELATION _T0_NEXT = SIBLING) & 

(LATER JCEYJRELATION = PARENT) 
then /* found UNCLE */ 
do; 

KEYJPERSON (KEYJ1NDEX) . RELATIONJTO_NEXT = UNCLE; 
KEY_PERSON (KEY_INDEX) . GENERATION_GAP = 

KEYJ»ERSON (KEYJLNDEX + 1) . GENERATI0NJ3AP; 
call CONDENSE_KEY_PERSONS (KEY_INDEX, 1); 
end; 
end FIND COUSINS NEPHEWS UNCLES; 
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/* Loop below will pick out valid adjacent strings of elements 
to be displayed. KEY_INDEX points to first element, 
LATER_KEY_INDEX to last element, and PRIMARY_INDEX to the 
element which determines the primary English word to be used. 
Associativity of adjacent elements in condensed table 
is based on English usage. */ 
KEY_INDEX - 1; 

put skip list (' Condensed path:'); 
CONSOLIDATE_ADJACENT_PERSONS : 

do while (KEY_PERSON (KEYJLNDEX) . RELATION_TO_NEXT ~= NULL_RELATION); 
KEY_RELATION = KEY_PERSON (KEY_INDEX) . RELATION_TO_NEXT ; 

LATER_KEY_INDEX = KEY_INDEX; 
PRIMARY_INDEX = KEY_INDEX; 

if KEY_PERSON (KEY_INDEX + 1) . RELATION_TO_NEXT ~= NULL_RELATION then 
do; /* seek multi-element combination */ 
ANOTHER_ELEMENT_POSSIBLE = TRUE; 
if KEY_RELATION - SPOUSE then 
do; 

LATER_KEY_INDEX - LATER_KEY_INDEX + 1; 
PRIMARY_INDEX = LATER_KEY_INDEX; 
if (KEY_PERSON (LATER_KEY_INDEX) . RELATION_TO_NEXT = SIBLING) | 

(KEY_PERSON (LATER_KEY_INDEX) . RELATION_TO_NEXT = COUSIN) 
then /* Nothing can follow SPOUSE -SIBLING or SPOUSE-COUSIN */ 

ANOTHER_ELEMENT_POSSIBLE - FALSE; 
end; 
/* PRIMARY_INDEX is now correctly set. Next if-statement 
determines if a following SPOUSE relation should be 
appended to this combination or left for the next 
combination. */ 
if ANOTHER_ELEMENT_POSSIBLE & 

(KEY_PERSON (PRIMARY_INDEX + 1) . RELATION_TO_NEXT = SPOUSE) 
/* Only a SPOUSE can follow a Primary */ 
then 

do; /* check primary preceding and following SPOUSE. */ 
PRIMARY_RELATION 

KEY_PERSON (PRIMARY_INDEX) . RELATION_TO_NEXT ; 
NEXT_PRIMARY_RELATION - 

KEY_PERSON (PRIMARY_INDEX + 2) . RELATION_TO_NEXT ; 
if (NEXT_PRIMARY_RELATION - NEPHEW | 
NEXT_PRIMARY_RELATION = COUSIN | 
NEXT_PRIMARY_RELATION = NULL_RELATION) 
I (PRIMARY_RELATION = NEPHEW) 
I ( ( PRIMARY_RELATION - SIBLING I 
PRIMARY_RELATION = PARENT) 
& (NEXT_PRIMARY_RELATION ~= UNCLE ) ) 
then /* append following SPOUSE with this combination. */ 

LATER_KEY_INDEX - LATER_KEY_INDEX + 1; 
end; /* check primary preceding and following SPOUSE */ 
end; /* multi-element combination */ 
call DISPLAY_RELATION (KEY_INDEX, LATER_KEY_INDEX, PRIMARY_INDEX); 
KEY__INDEX = LATER_KEY_INDEX + 1; 
end CONSOLIDATE_ADJACENT_PERSONS ; 
put skip list (' ' I I PERSON (KEY_PERSON (KEY_INDEX) . PERSON_INDEX) . NAME); 

/* End execution of RESOLVE PATH TO ENGLISH. 
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Begin utility procedures for RESOLVE_PATH_TO_ENGLISH. */ 

FULL_SIBLING: procedure (INDEX1, INDEX2) 
returns (bit(l)); 
/* Determines whether two PERSONS are full siblings, i.e., 
have the same two parents. */ 

declare 

(INDEX1, INDEX2) fixed binary (10,0); 

return 
((PERSON (INDEX1) . RELATIVE_IDENTIFIER (FATHER_IDENT) ~- NULL_IDENT) & 
(PERSON (INDEX1) . RELATIVE_IDENTIFIER (MOTHER__IDENT) ~= NULL_IDENT) & 
(PERSON (INDEX1) . RELATIVE_IDENTIFIER (FATHER_IDENT) = 

PERSON (INDEX2) . RELATIVE_IDENTIFIER (FATHER_IDENT) ) & 
(PERSON (INDEX1) . RELATIVE_IDENTIFIER (MOTHERJLDENT) = 

PERSON (INDEX2) . RELATIVE_IDENTIFIER (M0THER_IDENT) ) ); 
end FULL_SIBLING; 

CONDENSE_KEY_PERSONS: procedure (AT_INDEX, GAP_SIZE); 

/* CONDENSE_KEY_PERSONS condenses superfluous entries from the 

KEY_PERS0N array, starting at AT_INDEX. */ 
declare 

ATJLNDEX fixed binary (10,0), 
GAP_SIZE fixed binary (10,0); 
declare 

(RECEIVE_INDEX, SEND_INDEX) fixed binary (10,0); 
/* begin execution of CONDENSEJKEYJPERSONS */ 
RECEIVE_INDEX = ATJENDEX + 1; 
SEND_INDEX - RECEIVE_INDEX + GAP_SIZE; 

KEY_PERSON (RECEIVE_INDEX) - KEY_PERS0N (SEND_INDEX); 

do while (KEYJPERSON (SEND_INDEX) . RELATI0N_T0_NEXT ~= NULL_RELATION ) ; 
RECEIVE_INDEX - RECEIVE_INDEX + 1; 
SEND_INDEX = RECEIVE_INDEX + GAP_SIZE; 

KEYJPERSON (RECEIVE_INDEX) - KEY_PERS0N (SEND_INDEX); 
end; 
end C0NDENSE_KEY_PERS0NS ; 

/* End utility procedures. 
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Begin DISPLAYJR.ELATION, which does major work of displaying 
under RESOLVE_PATH_TO_ENGLISH. */ 

DISPIAY_RELATION: procedure (FIRST_INDEX, LAST_INDEX, PRIMARY_INDEX); 
/* DISPLAY_RELATION takes 1, 2, or 3 adjacent elements in the 
condensed table and generates the English description of 
the relation between the first and last + 1 elements. */ 
declare 

(FIRSTJNDEX, LASTJNDEX, PRIMARY_INDEX) fixed binary (10,0); 
declare 

DISPLAYJBUFFER character (80) varying, 
INLAW bit (1), 

THIS_PROXIMITY character (1), 
THIS_GENDER character (1), 
SUFFIX_INDICATOR fixed binary (6,0), 
(FIRST_RELATI0N, LASTJRELATION, PRIMARY_RELATION) 

fixed binary (4,0), 
( THIS_GENERATI0N_GAP, THIS_C0USIN_RANK) 
fixed binary (10,0); 

/* begin execution of DISPIAY_RELATI0N */ 

FIRST_RELATI0N = KEY_PERS0N (FIRST_INDEX) . RELATI0N_T0_NEXT ; 
LAST_RELATI0N = KEY_PERS0N (LAST_INDEX) . RELATION_TO_NEXT; 
PRIMARY_RELATI0N - KEYJPERSON (PRIMARY_INDEX) . RELATI0N_T0_NEXT ; 
/* set THIS_PROXIMITY */ 
if ((PRIMARY_RELATION - PARENT) & (FIRSTJtELATION = SPOUSE)) | 

((PRIMARY_RELATION - CHILD) & (LAST_RELATI0N = SPOUSE)) 
then 

THIS_PR0XIMITY = STEP; • 
else 

if PRIMARY_RELATI0N = SIBLING | 
PRIMARY_RELATI0N = UNCLE | 
PRIMARY_RELATI0N = NEPHEW I 
PRIMARY_RELATI0N = COUSIN 
then 

THIS_PR0XIMITY = KEY_PERS0N (PRIMARYJLNDEX) . PROXIMITY; 
else 

THIS_PR0XIMITY = FULL; 
/* set THIS_GENERATI0N_GAP */ 
if PRIMARY_RELATI0N = PARENT | 
PRIMARY_RELATION = CHILD | 
PRIMARY_RELATI0N = UNCLE | 
PRIMARY_RELATI0N = NEPHEW I 
PRIMARY_RELATI0N = COUSIN 
then 

THIS_GENERATI0N_GAP = KEY_PERS0N (PRIMARY_INDEX) . GENERATION_GAP; 
else 

THIS GENERATION GAP =0; 
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/* set INLAW */ 
INLAW = FALSE; 

if (FIRST_RELATION = SPOUSE) & 
(PRIMARY_RELATION = SIBLING | 
PRIMARY_RELATION = CHILD j 
PRIMARY_RELATION = NEPHEW I 
PRIMARY_RELATION = COUSIN) 
then 

INLAW = TRUE; 
if (LAST_RELATION = SPOUSE) & 
(PRIMARY_RELATION = SIBLING | 
PRIMARYJRELATION - PARENT I 
PRIMARY_RELATION = UNCLE | 
PRIMARY_RELATION = COUSIN) 
then 

INLAW = TRUE; 
/* set THISJCOUSINJRANK */ 
if PRIMARY_RELATION = COUSIN then 

THIS_COUSIN_RANK = KEYJPERSON (PRIMARY__INDEX) . COUSIN_RANK; 
else 

THIS_COUSIN_RANK = 0; 

/* parameters are set - now generate display. */ 

DISPLAY BUFFER = 

' ' Tl PERSON (KEY_PERSON (FIRSTJNDEX) . PERSONJENDEX) . NAME I I ' is 
if PRIMARY_RELATION = PARENT | 
PRIMARY_RELATION - CHILD | 
PRIMARY_RELATION = UNCLE I 
PRIMARY_RELATION = NEPHEW 
then 

do; /* write generation-qualifier */ 
if THIS_GENERATION_GAP >= 3 then 
do; 

DISPLAY_BUFFER = DISPLAYJBUFFER || 'great'; 
if THIS_GENERATION_GAP > 3 then 

DISPLAY_BUFFER = DISPLAYJBUFFER | | '*' | I 
TRIM (THIS_GENERATION_GAP - 2); 
DISPLAY_BUFFER - DISPLAY_BUFFER || '-'; 
end; 
if THIS_GENERATION_GAP >= 2 then 

DISPLAY_BUFFER = DISPLAY_BUFFER || 'grand-'; 
end; 
else 

if (PRIMARY_RELATION = COUSIN) & (THIS_COUSIN_RANK > 1) then 
do; 

DISPLAY_BUFFER = DISPLAYJ5UFFER 1 1 TRIM (THIS_COUSIN_RANK); 
SUFFIX_INDICATOR = mod (THIS_COUSIN_RANK, 10); 
if SUFFIX_INDICATOR > 3 then 

SUFFIX_INDICATOR = 0; 
DISPLAY_BUFFER - DISPLAYJBUFFER | | 

substr ('th st nd rd ', 3 * SUFFIX_INDICATOR + 1, 3); 
end; 


if THIS_PROXIMITY = STEP then 

DISPLAYJBUFFER = DISPLAYJBUFFER | | 'step-'; 
else 

if THISJPROXIMITY = HALF then 

DISPLAY BUFFER - DISPLAY BUFFER I I 'half- 
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THISJ3ENDER = PERSON (KEY_PERSON (FIRST_INDEX) 

if PRIMARY_RELATION = PARENT then 

if THIS_GENDER = MALE then DISPLAY_BUFFER = 
else DISPLAY_BUFFER = 

else if PRIMARY_RELATION = CHILD then 

if THIS_GENDER = MALE then DISPLAY_BUFFER = 
else DISPLAYJBUFFER = 

else if PRIMARY JRELATION = SPOUSE then 

if THIS_GENDER = MALE then DISPLAYJBUFFER = 
else DISPLAY_BUFFER = 

else if PRIMARY_RELATION = SIBLING then 

if THISJSENDER = MALE then DISPLAY_BUFFER = 
else DISPLAY_BUFFER = 

else if PRIMARY_RELATION = UNCLE then 

if THISJSENDER = MALE then DISPLAY_BUFFER = 
else DISPLAY_BUFFER = 

else if PRIMARY_RELATION = NEPHEW then 

if THISJSENDER = MALE then DISPLAYJBUFFER = 
else DISPLAY_BUFFER = 

else if PRIMARY_RELATION = COUSIN then 

DISPLAYJBUFFER = 

else 


PERSON INDEX) . GENDER; 


DISPLAY_BUFFER 
DISPLAYJBUFFER 

DISPLAYJBUFFER 
DISPLAY_BUFFER 

DISPLAY_BUFFER 
DISPLAYJBUFFER 

DISPLAY_BUFFER 
DISPLAYJBUFFER 

DISPLAY_BUFFER 
DISPLAY_BUFFER 

DISPLAYJBUFFER 
DISPLAY BUFFER 


DISPLAYJBUFFER 
DISPLAY BUFFER = DISPLAY BUFFER 


'father'; 
'mother'; 

'son'; 
'daughter'; 

'husband'; 
'wife'; 

'brother'; 
'sister'; 

'uncle'; 
'aunt'; 

'nephew' ; 
'niece'; 

'cousin'; 

'null'; 


if INLAW then 

DISPLAYJBUFFER = DISPLAYJ3UFFER || '-in-law'; 

if (PRIMARY_RELATION = COUSIN) & (THIS_GENERATION_GAP > 0) then 
if THISJ3ENERATIONJ3AP > 1 then 

DISPLAY_BUFFER = DISPLAY_BUFFER | | ' ' || 

TRIM (THISJ3ENERATIONJ3AP) jj ' times removed'; 
else 

DISPLAYJ5UFFER = DISPLAYJBUFFER || ' once removed'; 

DISPLAY_BUFFER = DISPLAYJBUFFER I I ' of; 
put skip list (DISPLAY BUFFER); 
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/* Begin utility procedure for DISPLAY_RELATION */ 

TRIM: procedure (NUMERIC_VALUE) returns (character (20) varying); 
/* Returns character representation of numeric values 

with no leading or trailing spaces. */ 
declare 

NUMERIC_VALUE fixed binary (10,0); 
declare 

STRING_REPRESENTATION character (20), 
( STARTJLOCATION, ST0P_L0CATI0N ) 

fixed binary (10,0); 
/* Begin execution of TRIM */ 

STRINGJREPRESENTATION = NUMERIC_VALUE ; 
do START_L0CATI0N = 1 to 20 

while (substr ( STRING JREPRESENTATION, STARTJ.0CATI0N, 1) = ' '); 
end; 
do ST0P_L0CATI0N = 20 to 1 by -1 

while (substr (STRING_REPRESENTATION, ST0P_L0CATI0N, 1) « ' '); 
end; 

return (substr (STRING_RE PRESENTATION, START_L0CATION, 
ST0PJL0CATI0N - STARTJLOCATION + 1)); 
end TRIM; 

end DISPLAY_RELATI0N; 

end RES0LVE_PATH_T0_ENGLISH; 

/* C0MPUTE_C0MM0N_GENES is second major procedure (after 
RES0LVE_PATH_T0_ENGLISH) under FIND_RELATI0NSHIP. */ 

C0MPUTE_C0MM0N_GENES: procedure (INDEX1, INDEX2); 

/* C0MPUTE_COMMON_GENES assumes that each ancestor contributes 
half of the genetic material to a PERSON. It finds common 
ancestors between two PERSONS and computes the expected 
value of the PROPORTION of common material. */ 
declare 

(INDEX1, INDEX2) fixed binary (10,0); 
declare 

C0MM0N_PR0P0RTI0N float decimal (6); 

/* begin execution of CCMPUTE_COMMON_GENES */ 

/* First zero out all ancestors to allow adding. This is necessary 

because there might be two paths to an ancestor. */ 
call ZER0JPR0P0RTI0N (INDEX1); 
/* now mark with shared PROPORTION */ 

call MARKPR0P0RTI0N (PERSON (INDEX1) . IDENTIFIER, 1.0, INDEX1); 
C0MM0N_PR0 PORTION = 0.0; 
call CHECK_COMM0N_PROPORTION (C0MM0N_PR0P0RTI0N, 

PERSON (INDEX1) . IDENTIFIER, 1.0, 0.0, INDEX2); 
put skip list (' Proportion of common genetic material = '); 
put edit (C0MM0N_PR0 PORTION) (e(13,5,6)); 

/* End execution of COMPUTE COMMON GENES. 
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Begin utility procedures. */ 

ZERO_PROPORTION: procedure (ZERO_INDEX) recursive; 

/* ZERO_PROPORTION recursively seeks out all ancestors and 
zeros them out. */ 

declare 

ZERO_INDEX fixed binary (10,0), 
THIS_NEIGHBOR pointer ; 
/* begin execution of ZER0_PR0 PORTION */ 

PERSON (ZERO_INDEX) . DESCENDANT_GENES = 0.0; 
THIS_NEIGHBOR = PERSON (ZER0_INDEX) . NEIGHBOR_LIST_HEADER; 
do while (THIS_NEIGHB0R ~= null()); 

if THIS_NEIGHB0R -> NEIGHBOR_EDGE = PARENT then 

call ZER0_PR0 PORTION (THIS_NEIGHB0R -> NEIGHBOR_INDEX); 
THIS_NEIGHBOR - THIS_NEIGHB0R -> NEXT_NEIGHB0R; 
end; 
end ZER0JPR0 PORTION; 

MARK_PRO PORTION: procedure (MARKER, PROPORTION, MARKEDJNDEX) recursive; 
/* MARK_PR0 PORTION recursively seeks out all ancestors and 
marks them with the sender's PROPORTION of shared 
genetic material. This PROPORTION is diluted by one-half 
for each generation. */ 

declare 

MARKER picture '999', 

PROPORTION float decimal (6), 

MARKEDJNDEX fixed binary (10,0), 

THIS_NEIGHB0R pointer; 

/* begin execution of MARKJROPORTION */ 

PERSON (MARKED_INDEX) . DESCENDANT_IDENTIFIER = MARKER; 
PERSON (MARKEDJENDEX) . DESCENDANT_GENES 

PERSON (MARKED_INDEX) . DESCENDANT_GENES + PROPORTION; 
THIS_NEIGHB0R = PERSON (MARKED_INDEX) . NEIGHB0R_LIST_HEADER; 
do while (THIS_NEIGHBOR ~= nullQ); 

if THISJJEIGHBOR -> NEIGHBOR_EDGE = PARENT then 
call MARK_PR0 PORTION (MARKER, PROPORTION / 2.0, 

THISJJEIGHBOR -> NEIGHB0R_INDEX); 
THIS_NEIGHB0R = THISJJEIGHBOR -> NEXTJJEIGHBOR; 
end; 
end MARK PROPORTION; 
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CHECK_COMMON_PROPORTION: procedure 

(COMMON_PROPORTION, MATCH_IDENTIFIER, PROPORTION, 
ALREADY_COUNTED, CHECK_INDEX) recursive; 
/* CHECK_COMMON_PROPORTION searches all the ancestors of 
CHECK_INDEX to see if any have been marked, and if so 
adds the appropriate amount to COMMON_PROPORTION. */ 

declare 

C0MMON_PR0P0RTION float decimal (6), 
MATCH_IDENTIFIER picture '999', 
PROPORTION float decimal (6), 

ALREADY_COUNTED float decimal (6), 
CHECKJNDEX fixed binary (10,0), 

THIS_NEIGHB0R pointer, 

THIS_C0NTRIBUTI0N float decimal (6); 

/* begin execution of CHECKJCOMMONJPROPORTION */ 

if PERSON (CHECKJNDEX) . DESCENDANTJDENTIFIER = MATCHJEDENTIFIER then 
/* Increment C0MM0NJPR0 PORTION by the contribution of 

this common ancestor, but discount for the contribution 
of less remote ancestors already counted. */ 
do; 
THIS_C0NTRIBUTI0N = PERSON (CHECK_INDEX) . DESCENDANT_GENES 

* PROPORTION; 
C0MM0N_PR0 PORTION = C0MM0N_PR0P0RTI0N 

+ THISJCONTRIBUTION - ALREADY_COUNTED; 
end; 
else 

THIS_CONTRIBUTION = 0.0; 
THIS_NEIGHBOR = PERSON (CHECK_INDEX) . NEIGHBOR_LIST_HEADER; 
do while (THIS_NEIGHB0R ~= null()); 

if THIS_NEIGHBOR -> NEIGHB0R_EDGE = PARENT then 

call CHECK_C0MMON_PR0PORTION (C0MM0N_PR0 PORTION, 
MATCHJEDENTIFIER, PROPORTION / 2.0, 
THIS_C0NTRIBUTI0N / 4.0, 
THIS_NEIGHBOR -> NEIGHBORJLNDEX); 
THIS_NEIGHB0R = THIS_NEIGHBOR -> NEXT_NEIGHBOR; 
end; 
end CHECR_C0MM0N_PR0P0RTI0N; 

end C0MPUTE_C0MM0N_GENES ; 

end FIND_RELATIONSHIP; 

end RELATE; 
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